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ABSTRACT 


A  compiler  for  a  subset  of  the  Automated  Data  Processing 
Equipment  Selection  Office  (ADP^SO)  HTP0-C030I  has  been 
implemented  on  a  microcomputer.  The  implementation  provides 
nucleus  level  constructs  and  file  options  from  the  ANSI 
COBOL  package  along  with  the  PERFORM  UNTIL  construct  from  a 
higher  level  to  give  increased  structural  control.  The 
language  was  implemented  through  a  compiler  and  run-time 
package  executing  under  the  CP/M  operating  system  of  an  8080 
microcomputer-based  system.  Soth  the  compiler  and 
interpreter  can  be  executed  in  20K  bytes  of  main  memory.  A 
program  consisting  of  8.5K  bytes  of  intermediate  code  can  be 
supported  on  this  size  machine.  Modification  of  the  compiler 
and  interpreter  programs  can  be  accomplished  to  take 
advantage  of  larger  machines.  The  programs  that  make  up  the 
compiler  and  interpreter  package  require  50K  bytes  of  disk 
storage. 
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I  .   INTRODUCTION 

A.   BACKGROUND 

The  NPS  MICRO-COBOL  Compiler/Interpreter  was  initially 
(1976)  developed  to  demonstrate  that  it  was  feasible  to 
implement  a  COBOL  compiler  on  a  micro-computer.  It  was  known 
that  the  C030L  language  used  would  have  to  be  a  subset  of 
ANSI  COBOL  because  of  the  restriction  imposed  by  the  size  of 
a  micro-computer  memory.  A  subset  of  ANSI  COBOL, 
specifically  ADPSO  HYPO-COBCL,  was  selected  as  the  basis  for 
the  implementation  [3].  Additional  motivation  was  provided 
by  the  DOD  requirement  that  all  computers  used  in  a 
non-tactical  environment  be  capable  of  executing  COBOL. 

The  previous  work  was  directed  toward  five  major  areas: 
1.)  selecting  a  suitable  COBOL  subset  to  operate  on,  2.) 
develop  the  associated  grammar  for  the  language,  3.) 
determine  what  type  of  compiler  to  design,  4.)  design  and 
code  the  compiler,  and  5.)  design  and  code  the  interpreter. 
The  interpreter  performs  the  functions  of  a  classical 
linking  loader,  resolving  forward  address  references  and 
establishing  the  run  time  intermediate  code  environment,  as 
well  as,  executing  the  intermedite  code. 

The  establishment  of  a  suitable  language  was  easily 
determined  since  HYPO-COBOL  was  a  Department  of  the  Navy 
approved  subset  of  COBOL,  designed  to  place  minimal 
requirements   on   a   system   for   compiler   support.    Where 
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possible,  short  constructs  were  used  in  the  place  of  longer 
ones.  Where  more  than  one  reserved  word  served  the  same 
function  in  COBOL  the  shortest  form  was  used.  There  is  no 
optional  verbage  in  the  language,  and  no  duplicate 
constructs  perform  the  same  function.  Limits  were  placed  on 
all  statements  that  had  a  variable  input  format  so  that  all 
statements  had  a  fixed  maximum  length.  Where  possible,  such 
constructs  were  removed  completely  from  the  language.  In 
addition,  user  defined  identifier  names  were  limited  to 
twelve  characters  to  reduce  symbol  table  storage 
reauirements . 

Rather  than  include  the  standard  levels  of 
implementation  for  all  of  the  modules,  constructs  were 
included  only  as  required.  In  addition  to  low  level 
constructs,  the  PERFORM  UNTIL  construct  was  included  to 
allow  better  program  structure.  Further  justification  for 
the  manner  of  subsetting  and  a  highly  detailed  description 
of  each  element  of  the  language  is  contained  in  the 
HYPO-COBOL  language  specifications  reference  3.  ?or  a 
comparison  of  HYPO-COBOL  constructs  that  are  not  supported 
by  MICR0-CC30L  see  appendix  G. 

The  grammar  for  the  MICRO-COBOL  language  was  defined  as 
LALR(l).  The  compiler  design  was  based  on  a  table-driven 
parser  for  the  LALR(l)  grammar.  The  algorithm  used  to 
develope  the  parse  tables  for  the  compiler  was  developed  by 
7.  Lalonge  [17] . 

The   basic   design   and   coding   of   the   compiler   and 


interpreter  was  completed  prior  to  the  current  thesis  work 
by  Scott  Allan  Crai*  [2].  Modification  to  the  original 
thesis  work  was  conducted  by  Phil  Mylet  [151. 

B.  OPERATING  ENVIRONMENT 

The  NPS  MICRO-COBOL  compiler  and  interpreter  are 
designed  to  run  under  the  CP/M  operating  system  on  an  8060 
or  ZS0  hased  microcomputer  with  at  least  20K  bytes  of  main 
memory.  The  compiler  programs  are  designed  to  use  no  more 
than  12K  bytes  of  main  memory,  while  the  interpreter  program 
uses  approximately  8K  bytes.  The  compiler  and  interpreter 
require  50K  bytes  of  disk  storage  for  the  programs  that  make 
up  the  compiler/interpreter  package.  For  information  on 
creating  MICRO-COBOL  source  programs  and  CP/M  see  references 
4  and  5. 

C.  GOALS  AND  OBJECTIVES 

The  primary  goal  of  this  thesis  project  was  to  complete 
the  implementation  of  an  8080  microcomputer  based 
compiler/interpreter,  which  could  compile  and  execute  a 
subset  of  the  ANSI  Standard  HYPO-COBOL  language 
specification.  To  achieve  this  goal  both  the  compiler  and 
interpreter  would  require  testing,  debugging,  modification 
and  implementation  (extension)  of  any  necessary  additional 
language  constructs.  It  was  also  decided  that  while  testing 
and   debugging,   the   documentation   of   the   compiler's  and 
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interpreter's  internal  structures,  memory  organization, 
interfaces  and  module  functions  would  "be  accomplished. 

Since  the  amount  of  testing  and  debugging  effort  could 
not  be  accurately  determined,  several  subgoals  were 
established  which  would  be  undertaken  if  adequate  time  was 
available.  These  time  dependent  goals  included  the 
validation  of  the  compiler  and  interpreter  and  the  inclusion 
of  additional  language  constructs  not  previously 
implemented . 

In  addition  to  the  above  goals,  it  was  considered 
beneficial  to  update  and  incorporate  all  previous  thesis 
documentation  into  the  present  NPS  MICRO-COBOL  compiler  and 
interpreter  documentation.  This  documentation  is  appended  to 
this  thesis. 

D.   PROBLEM  DEFINITION 

Tor  software  performance  assessment,  a  series  of  simple 
COBOL  source  programs  and  the  Navy  Automated  Data  Processing 
Equipment  Selection  Office  HYPO-COBOL  validation  test 
programs  (HCCVS)  were  compiled  and  execution  was  attempted. 
An  evaluation  of  the  test  results  indicated  that  the 
compiler  and  interpreter  could  only  compile  and  execute  very 
simple  test  programs.  In  particular,  the  compiler  was  unable 
to  compile  past  the  file  section  of  the  first  validation 
program. 

A  review  of  the  compiler  and  interpreter  documentation 
led   to   several  additional   conclusions.   The  compiler  and 
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interpreter  were  difficult  to  understand,  and  program  losic 
flow  was  hard  to  follow,  because:  1.)  modular  functions  were 
not  explained  well,  2.)  documentation  on  the  module 
interfacing  was  inadequate,  3.)  complete  specifications 
describing  the  internal  structures  and  memory  organization 
did  not  exist,  and  4.)  few  comments  were  included  within  the 
source  code  listings. 
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II .   NPS  MICRO-COBOL  COMPILER 

A.   GENERAL  DESCRIPTION 

The  MICRO-COBOL  compiler  is  a  one  pass  compiler  that 
scans  and  parses  MICR0-C030L  source  programs,  and  generates 
intermediate  code  (pseudo-instructions)  for  the  interpreter 
(pseudo-machine).  The  scanner  design  is  similar  to  most 
other  scanner  implementations.  The  parser  is  an  LALR(l) 
table-driven  design,  implemented  in  the  PLM80  programming 
language  [8] .  The  parse  tables,  as  stated  before,  were 
generated  using  an  algorithm  developed  at  the  University  of 
Toronto  [17]  . 

The  compiler  reads  the  source  program  from  a  disk:  file, 
extracts  the  needed  information  for  the  symbol  table  and 
writes  the  pseudo-instructions  to  an  intermediate  code  file. 
To  accomplish  this  function,  the  compiler  consists  of  three 
modules:  PART  ONE,  IREADER,  and  PART  TWO. 

3.   SYMBOL  TABLE 

The  symbol  table  is  the  key  data  structure  in  the 
compiler.  Information  concerning  identifiers,  files,  and 
records  specified  in  the  DATA  DIVISION  of  the  MICRO-COBOL 
source  program  is  stored  in  the  symbol  table,  alon^  with 
labels  specified  in  the  PROCEDURE  DIVISION. 

The  symbol  table  structure  consists  of:  1.)  a  sixty-four 
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address  hash  table,  2.)  a  fixed  length  field  of  thirteen 
bytes  for  each  symbol  table  entry,  and  3.)  a  variable  length 
field  to  hold  the  name  of  each  identifier.  Since  each 
identifier  name  is  limited  to  twelve  ASCII  characters  the 
symbol  table  entry  for  identifiers  can  vary  in  length  from 
thirteen  to  twenty-five  bytes.  The  bytes  of  each  symbol 
table  entry  are  grouped  into  various  fields  of  either  one  or 
two  bytes  depending  on  the  storage  requirements.  The 
thirteen  bytes  of  the  fixed  length  field  entry  are  numbered 
from  zero  to  twelve  and  the  variable  length  field  begins 
with  byte  thirteen.  In  referencing  a  specific  field  a  byte 
index  with  a  value  from  zero  to  thirteen  is  utilized. 

The  symbol  table  entry  for  a  single  identifier  could 
contain  up  to  nine  different  attributes  of  that  identifier, 
although  not  all  identifiers  required  the  full  range  of 
attributes.  The  various  fields  in  the  symbol  table  contained 
different  information  depending  on  whether,  for  example,  an 
identifier  was  a  numeric  or  alphanumeric  type.  Four  of  the 
fields  contained  the  same  information  for  all  identifiers. 
These  fields  were:  1.)  field  zero  (bytes  zero  and  one 
contained  the  collision  link,  2.)  field  one  (byte  two) 
contained  the  type  of  the  identifier,  3.)  field  two  (byte 
three)  contained  the  length  of  the  identifier  name,  and  4.) 
field  thirteen  (byte  thirteen)  was  the  beginning  of  the 
ASCII  character  representation.  It  should  be  noted  that  an 
identifier  of  type  FILLER  would  not  have  a  name  associated 
with   it,   so   field   two   would   contain   a   zero  and  field 


14 


thirteen  would  not  exist. 

Entry  into  the  symbol  table  is  accomplished  by  using  a 
HASH  function  on  the  ASCII  character  representation  of  the 
identifier  name.  This  function  generates  an  even  number 
between  zero  and  126.  The  numbpr  is  used  as  an  index  into 
the  hash  table  by  specifying  an  offset  from  the  base  of  the 
hash  table.  The  hash  table  can  hold  sixty-four  uniquely 
determined  address  references  to  identifiers.  The  hash  table 
entry  associated  with  each  index  reference  heads  a  linked 
list  of  identifiers  with  the  same  HASH  function  value.  The 
linked  list  structure  provides  for  additional  identifier 
storage  and  therefore  the  number  of  uniaue  identifiers  is 
not  limited  by  the  sixty-four  index  values  generated  by  the 
HASH  function.  A  zero  entry  in  the  hash  table  indicates  that 
there  is  no  identifier  with  that  HASH  function  value.  In 
tracing  through  the  linked  list  of  identifiers  the  most 
recently  declared  variable  appears  at  the  end  of  the  list. 
See  figure  [II-ll  for  an  example  of  the  computation  of  a 
hash  value.  See  figure  [II-2]  for  and  example  of  the  hash 
table  indexing  and  linking  of  hash  values. 
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HASH  VALUE  COMPUTATION 

HASH  Function  value:  sum  of  identifier  ASCII  characters 
logically  and  with  3FH  then  shifted  left  (SHL)  one  bit. 
HASHBASE  =  2000H 

E.T.(AB)  =  HASHBASE  +  SHL(((41H  +  42H )  AND  3FE),1)  =  2006H 
H.F.(BA)  =  HASHBASE  +  SHL(((42H  +  41H)  AND  3FH)tl)  =  2006H 

FIGURE  II-l 
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FIGURE  1 1-2 
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1 .  Numeric  Values 

The  symbol  table  entry  for  numeric  values  can 
contain  up  to  seven  attributes  of  the  variable.  These 
attributes  are:  1.)  identifier  type,  2.)  length  of  variable 
name  3.)  beginning  address  of  variable  storage,  4.)  numeric 
count  (number  of  storage  locations  required  by  the 
identifier),  5.)  level  number,  6.)  number  of  digits  to  the 
right  of  the  decimal  point,  and  7.)  the  variable  name. 
Figures  [1 1-3]  and  [II-4]  illustrate,  respectively,  the 
following  two  COBOL  declarations: 

01  NUM  PIC  9(9). 

01  NUM  PIC  9(6). 999  OCCUP.S  12  TIMES. 

2.  Numeric  Edit 

The  numeric  edit  symbol  table  entry  expands  on  the 
numeric  symbol  entry  and  utilizes  bytes  eight  and  nine  to 
hold  the  beginning  address,  in  the  constants  area,  of  the 
edit  field  mask.  This  mask  allowed  for  the  insertion  of  the 
following  characters  into  and  output  display  of  a  numeric 
number:  fixed  and  floating  dollar  signs,  credit(CR)  and 
debit(DB)  sisns,  asterisk  fill,  'Z*  character  fill,  and  plus 
("+")  and  minus  ("-")  signs.  It  should  be  noted  that  an 
identifier  with  a  numeric  edit  field  value  can  not  be  used 
in  an  arithmetic  statement. 
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NUMERIC  SYMBOL  TABLE  ENTRY. 


BYTE       SYMBOL  TABLE  VALUE 

0-1     collision  link 
!  (00  00) 

2  i  type  identifier 
!  (10) 

3  !  length  of  identifier 
!  name  (03) 

j  beginning  address 
4-5     of  identifier 

!  storage  (04  25) 

6-7    !  length  of  identifier 
i  storage  (09  00) 

8-9    !  not  used 

10  j  level  entry  (01) 

11  !  decimal  count  (00) 

12     !  occurances  (00) 

13-15   !  identifier  name 
!  (4E  55  4D) 

01  NUM  PIC  9(9) . 
FIGURE  1 1-3 
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NUMERIC  SYMBOL  TABLE  ENTRY  WITH  DECIMAL 
AND  OCCURS  CLAUSE 


BYTE       SYMBOL  TABLE  VALUE 

0-1    j  collision  link 
!  (09  2E) 

2  |  type  identifier 
|  (10) 

3  !  length  of  identifier 

name  (03) 

{  beginning  address 
4-5    !  of  identifier  stoi— 
!  age  (0D  25) 

6-7    !  length  of  identifier 
storage  (09  00) 

8-9    !  not  used 

10     ,'  level  entry  (01) 

11  j  decimal  count  (03) 

12  !  occurances  (0C) 

13-15   |  identifier  name 
!  (4E  55  4D) 

01  NUM  PIC  9(6). 999  OCCURS  12  TIMES 

FIGURE  1 1 -4 
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3.  Alpha  or  Alphanumeric 

The  alpha  and  alphanumeric  symbol  table  entries 
appear  similarly  in  the  symbol  table  except  for  their  type 
fields.  Six  entries  appear  in  the  symbol  table  for  these 
identifiers:  1.)  identifier  type,  2.)  length  of  identifier 
name,  3.)  beginning  address  of  storage,  4.)  number  of 
storage  locations  required  by  identifier,  5.)  level  entry, 
and  6.)  identifer  name.  Figure  [II —5]  illustrates  an  alpha 
symbol  table  entry  for  the  following  identifier  declaration: 

01  ALPHA  PIC  .A  (3). 

4.  Alpha  Zdit 

The  alpha  edit  symbol  table  entry  expands  on  the 
alpha  and  alphanumeric  edit  types  and  utilizes  bytes  eight 
and  nine  to  hold  the  beginning  address  of  the  edit  field 
mask.  These  mask  fields,  which  are  stored  in  the  constants 
area  of  the  pseudo-machine,  contain  the  characters  necessary 
to  edit  an  output  so  that,  for  example,  slashes  or  blanks 
can  be  interspersed  in  the  display  output. 
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ALPHA  SYMBOL  TABLE  ENTRY 


BYTE  SYMBOL  TABLE  VALUE 

0-1    j  collision  link 

!  (00  00) 

2  i  type  identifier 
!  (08) 

3  !  length  of  identifier 
!  (05) 

I  beginning  address 

4-5   i  of  identifier 

!  storage  (16  25) 

6-7    !  length  of  identifier 

!  storage  (08  00) 

8-9    '  not  used 

10  !  level  entr7  (01) 

11  j  not  used 

12  !  not  used 

13-17   j  identifier  name 

!  (41  4C  50  48  41) 


01  ALPHA  PIC  A(8) . 
FIGURE  1 1-5 
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5.  Tables 

NPS  MICRO-COBOL  was  designed  to  support  singly 
indexed  tables.  These  tables  are  established  by  using  an 
OCCURS  clause  with  the  PICTURE  clause  of  an  identifier.  If 
an  identifier  is  specified  as  a  table  the  number  of 
occurances  of  the  table  are  placed  in  byte  twelve  of  the 
symbol  table  entry  for  that  identifier.  The  table  identifier 
in  COBOL  is  similar  to  the  subscripted  variable  in  other 
programming  languages.  Tor  example,  the  statement,  "dl  NUM 
PIC  9(9)  OCCURS  12  TIMES",  generates  the  symbol  table  entry 
illustrated  in  figure  [II -4] . 

6.  Labels 

Labels  generate  the  simplest  of  all  symbol  table 
entries,  only  four  or  five  attributes  are  associated  with 
the  label.  The  variability  depends  on  whether  the  label  is 
declared  in  the  source  program  before  or  after  the  label  is 
referenced  by  a  GO  or  PERFORM  statement.  In  the  event  a 
label  is  specified  before  a  GC  or  PERFORM  statement 
references  it,  the  symbol  table  would  contain  the  following 
1.)  the  type  associated  with  label,  2.)  the  length  of  the 
identifier  name,  3.)  the  address  of  the  first  intermediate 
code  instruction  following  the  appearance  of  the  label  in 
the  source  program  (bytes  four  and  five),  4.)  the  last 
executable  instruction  associated  with  the  label  (bytes 
eiffht  and  nine)  This  would  be  either  the  last  executable 
instruction   encountered   before  another  label  or  the  end  of 
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the  program.,  and  5.)  the  label  name. 

In  the  event  a  label  Is  referenced  by  a  GO  or 
PERFORM  statement  before  the  label  actually  appears  in  the 
code,  the  symbol  table  entry  performs  a  different  function 
than  just  indicating  the  beginning  and  ending  of  the 
paragraph  associated  with  the  label.  The  same  symbol  table 
fields  are  used,  however  their  meanings  are  different.  The 
type  is  set  to  the  unresolved  label  type  of  (0??H).  The 
label  remains  unresolved  until  the  beginning  and  the  ending 
addresses  of  the  associated  paragraph  are  determined. 

If  a  label  is  referenced  for  the  first  time  by  a  GC 
statement  the  symbol  table  is  initialized  with  the 
following:  1.)  unresolved  label  type  (0FFH),  2.)  the  address 
of  the  GO  statement  (the  intermediate  code  would  be  ERN  30 
00  where  the  zeros  indicate  where  the  address  of  the  label 
is  to  be  bacfrstuf fed) .  See  section  III-B  for  specific 
explanation  of  pseudo-machine  instructions.,  3.)  the 
remainder  of  the  label  entries  would  be  the  same  except  no 
entry  is  made  for  the  last  executable  instruction  associated 
with  the  label.  If  an  additional  reference  is  made  to  the 
label  by  a  subsequent  GC  statement  the  following  action 
would  occur:  1.)  the  current  address  (bytes  four  and  five) 
would  be  placed  in  the  branch  address  of  the  GC  statement, 
2.)  the  address  of  this  branch  statement  would  be  placed  in 
bytes  four  and  five  of  the  symbol  table  entry.  This 
procedure  facilitates  linking  together  all  unresolved 
references  to  labels  so  that  when  the  label  are  resolved  the 
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correct  branch  address  could  be  placed  Into  the  intermediate 
code. 

Encountering  a  PERFORM  statement  before  a  label  is 
declared  causes  the  following  actions:  l.)bytes  four  and 
five  contain  the  address  of  the  next  byte  of  intermediate 
code  following  the  PER  intermediate  code  instruction,  2.)and 
bytes  eight  and  nine  contain  the  address  of  the  third  byte 
following  the  PER  instruction.  If  a  subsequent  PERFORM 
statement  is  encounted  before  the  label  is  resolved  the  two 
address  fields  in  the  symbol  table  would  be  copied  to  tne 
associated  bytes  following  the  most  current  PERFORM 
statement  and  the  address  of  the  first  and  third  bytes 
following  the  PER  instruction  would  be  copied  into  the 
symbol  table.  It  should  be  pointed  out  that  any  number  of 
PERFORM  and  GO  statements  can  be  specified  before  a  label  is 
resolved . 

7.   Files 

The  symbol  table  entries  for  files  are  the  most 
difficult  to  understand.  The  complexity  of  the  entries  is 
due  to  the  way  files  and  records  are  declared  in  a 
MICRO-COBOL  program.  The  symbol  table  entry  for  a  file 
consists  of  the  following:  1.)  byte  two  contains  the  type, 
2.)  byte  three  contains  the  length  of  the  file  name,  3.) 
bytes  four  and  five  contain  the  address  in  the  symbol  table 
of  the  first  01  level  record  associated  with  the  file,  4.) 
bytes  eight   and   nine  contain  the  beginning  address  of  the 
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file  control  block  and  input/output  buffer  for  the  file, 
(this  would  be  the  actual  address  in  the  data  section  of  the 
pseudo-machine  for  the  beginning  of  the  165  bytes  associated 
with  the  file),  5.)  if  the  file  has  a  key  entry  associated 
with  it  (access  via  RANDOM  or  RANDOM  RELATIVE)  bytes  ten  and 
eleven  contain  the  symbol  table  address  of  the  access  key 
variable,  and  6.)  the  rest  of  the  entry  contains  the  file 
name.  Figure  [I 1—6]  illustrates  a  file  entry  in  the  symbol 
table. 

8 .   Records 

This  entry  contains  seven  attributes  of  a  record. 
Three  are  the  same  as  all  other  entries  type,  name,  and 
length  of  name.  While  the  other  four  are:  1.)  bytes  four  and 
five  contain  the  initial  storage  address  for  the  record,  2.) 
bytes  six  and  seven  contain  the  number  of  bytes  of  storage 
for  the  record,  3.)  bytes  eight  and  nine  contain  the  symbol 
table  address  of  the  file  associated  with  the  record  (this 
facilitates  referencing  the  file  when  the  record  is 
written),  and  4.)  byte  ten  contains  the  level  entry  for  the 
record. 
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FILE  SYMBOL  TABLE  ENTRY 
SAMPLE  SOURCE  PROGRAM  FILE  DECLARATION 

INPUT-OUTPUT  SECTION. 

FILE-CONTROL. 

SELECT  POSTER-FIL 

ORGANIZATION  RELATIVE 
ACCESS  PANDOM  RELATIVE  NU'M 
ASSIGN  CS81-FIL. 


BYTE       SYMBOL  TABLE  VALUE 
0-1    !  collison  link 

2  !  type  file 
!  (03) 

3  !  length  of  file 
!  name  (05) 

1  symbol  table 
4-5    !  address  of  first 
'  01  level  record 
!  (09  2E) 

6-7    !  not  used 

8-9     !  first  address  of 
!  FC3  S,  buffer 
!  (0E  26) 

10-11    !  symbol  table 

!  address  of  key 
!  (33  27) 

12     !  not  used 

13-17    !  file  name 

!  (52  4?  53  54  45  52 
5F  46  49  4C) 

FIGURE  1 1 -6 
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C.   COMPILER  MODULE   PART  ONE' 

1 .  Purpose 

This  first  module  of  the  compiler  performs  several 
functions.  First,  it  establishes  the  interface  between  the 
compiler  and:  1.)  the  input  source  file  (of  type  'CBL'),  2.) 
the  output  intermediate  code  file  (of  type  "CIN"),  and  3.) 
the  IREADER  module  which  reads  and  passes  control  to  PART 
TWO  of  the  compiler.  Second,  it  scans  and  parses  the  source 
program  statements  up  to  the  PROCEDURE  DIVISION.  Third,  it 
generates  output  consisting  of  the  symbol  table  entries 
(saved  in  memory)  and  data  initialization  intermediate  code. 

2 .  Control  Actions 

By  executing  the  command  COBOL  (source  program>,  the 
object  code  for  PART  ONE  of  the  compiler  is  loaded  into 
memory  starting  at  100H  (if  necessary  this  can  be  modified 
for  different  machines)  by  the  CP/M  operating  system. 
Execution  of  PART  ONE  loads  the  program  name  associated  with 
the  source  program  into  the  input  file  control  bloc*  located 
at  5CE.  This  allows  the  source  program  name  to  be  saved 
until  actual  source  program  compilation  begins. 

Next,  the  control  program,  IREADER,  is  moved  to  high 
memory  just  below  the  BDOS  (see  reference  4  for  an 
explanation  of  BDOS  and  other  CP/M  associated  names).  For 
example,  using  an  INTEL  Corporation  625  MDS  microcomputer 
system  with  the  CP/M  operating  system,  the   IREADER   routine 
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is  moved  to  high  memory  starting  at  0E000H  and  continuing 
through  0D0FFH.  This  is  done  for  two  reasons:  1.)  it  allows 
the  symbol  table  of  the  source  program  to  begin  at  the  next 
address  following  the  object  code  for  PART  ONE,  and  2.) 
places  IREADER  high  enough  in  memory  so  that  it  is  not 
destroyed  by  creation  of  the  symbol  table.  See  figures 
[II-7]  and  [II —81  for  illustrations  of  the  PART  ONE  memory 
organization  before  and  after  the  IREA3ER  routine  is  moved. 
The  purpose  of  the  IREADER  routine  will  be  explained  in  the 
next  section. 
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MEMORY  ORGANIZATION  BEFORE  IREACER  ROUTINE  MOVED 


BDOS 


Free  Area 


Ireader  Routine 
Before  Move 


Part  1  of  Compiler 


F000H 

Top  of  Memory 


D100H 


100H 

000H 


FIGURE  II-7 
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MEMORY  ORGANIZATION  AFTER  IREAEER  ROUTINE  *CV3E 


3D0S 


Ireader  Routine 
After  Move 


Free  Area ( .Memory) 


Part  1  of  ComDiler 


x   G  o  XJ  .* 

To?    of   Memory 


D100H 


D002H 


100H 

000H 


FIGUR1?    1 1-3 


Next,  the  interface  between  the  compiler  and  the 
input  file  <source  program>  and  the  output  file 
intermediate  code  file>  is  established.  The  input  file 
control  block  associated  with  the  source  file  is  Initialized 
and  the  input  file  is  opened.  The  input  file  name  is  copied 
to  the  output  file  control  block  (FCB)  and  if  there  is  ar 
intermediate  code  file  already  residing  on  the  disk,  it  is 
erased.  The  output  FCB  is  initialized  and  a  file  directory 
entry  established  for  the  new  copy  of  the  intermediate  code 
file. 

Prior  to  beginning  the  scanning  and  parsing  actions, 
the  first  128  byte  record  of  the  input  file  is  read  into  the 
input  buffer,  located  at  30H  (default  I/C  buffer  for  C?/tf). 
The  scanner  is  primed  with  the  first  character  of  the  input 
program,  and  scanning  and  parsing  actions  continue  from  this 
point  in  PART  ONE  until  the  PFOCEDURS  DIVISION  of  the  source 
program  is  encountered;  at  this  time  compilation  is 
suspended. 

3 .   Symbol  Table  Entries 

Entries  made  in  the  symbol  table  by  ?A?T  ONE  will 
consist  of  all  identifiers  declared  in  the  DATA  DIVISION  of 
the  source  program.  By  refering  to  the  Symbol  Table  Section 
above,  an  explanation  may  be  obtained  regarding  the  various 
types  of  symbol  table  entries. 
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4 .   Intermediate  God?  Generation 

Pseudo-instructions  are  written  to  the  intermediate 
code  file  for  several  different  reasons  while  PAFT  ONE  is 
scanning  and  parsing  the  source  program.  The  first 
intermediate  code  generated  occurs  when  the  INPUT-OUTPUT 
SECTION  of  a  source  program  is  nonempty.  Within  the  FILE 
CONTROL  PARAGRAPH  of  this  section,  instructions  are 
generated  to  initialize  the  FCP  for  the  file  name  associated 
with  the  SELECT  statement.  The  name  associated  with  the 
ASSIGN  statement  is  placed  in  the  FCB  and  is  used  in 
referencing  the  file  on  the  disk. 

Two  other  instances  of  intermediate  code  generation 
occur  in  the  WORKING  STORAGE  SECTION  of  a  source  program. 
Anytime  a  record  or  elementary  identifier  entry  has  an 
edited  PICTURE  CLAUSE,  code  to  initialize  the  storage 
beginning  at  the  address  specified  in  the  formatted  mask 
attribute  of  the  symbol  table  entry  will  be  written  to  the 
intermediate  code  file.  When  a  record  or  elementary 
identifier  entry  has  an  associated  numeric  or  nonnumeric 
VALUE  CLAUSE,  code  to  initialize  the  storage  beginning  at 
the  address  specified  in  the  value  location  attribute  of  the 
symbol  table  entry  will  be  written  to  the  intermediate  code 
file. 

The  final  pseudo-instruction  written  to  the 
intermediate  code  file  is  the  SCD  instruction.  This  occurs 
when  the  parser  parses  the  word  PROCEDURE  in  the  source 
program;  control  is  then  passed  to  PART  TWO  and   compilation 
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continues . 

5.   Parser  Actions 

The  actions  corresponding  to  each  parse  step  are 
explained  below.  In  each  case,  the  grammar  rule  that  is 
being  aoplied  is  given,  and  an  explanation  of  what  program 
actions  take  place  for  that  step  has  been  included.  In 
describing  the  actions  ta*en  for  each  parse  step  there  has 
been  no  attempt  to  describe  how  the  symbol  table  is 
constructed,  what  pseudo-instructions  are  generated  or  how 
the  values  are  preserved  on  the  stack.  The  intent  of  this 
section  is  to  describe  what  information  needs  to  be  retained 
and  at  what  point  in  the  parse  it  can  be  determined.  Where 
no  action  is  reauired  for  a  given  statement,  or  where  the 
only  action  is  to  save  the  contents  of  the  top  of  the  stack, 
no  explanation  is  given.  Questions  regarding  the  actual 
manipulation  of  information  should  be  resolved  by  consulting 
the  programs. 

1  <program>  :  :=  <id-div>  <e-div>  <d-div>  PROCEDURE 

Reading  the  word  PROCEDURE  terminates  the  first 
part  of  the  compiler. 

2  <id-div>  ::=  IDENTIFICATION  DIVISION.  PP.OGRAM-ID. 

<comment>  .  <auth>  <date>  <sec> 

3  <auth>  : :=  AUTHOR  .  <comment>  . 

4  1  <empty> 

5  <date>  ::=  DATE-WRITTEN  .  <comment>  . 

6  !  <empty> 
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7  <sec>  ::=  SECURITY  .  <commert>  . 

8  !  <empty> 

9  <comment>  : :=  <input> 

10  !  <comment>  <iaput> 

11  <e-div>  ::=  ENVIRONMENT  DIVISION  .  CONFIGURATION 

SECTION  . 
<scr-obj>  <i-o> 

12  <src-obj>  ::=  SOURCE-COMPUTER  .  <comment>  <debug>  . 

OBJECT-COMPUTER  .  <comment>  . 

13  <debug>  ::=  DE3UGGING  MODE 

Set  a  scanner  toggle  so   that   debug  lines   will   be 
read. 

14  !  <empty> 

15  <i-o>  ::=  INPUT-OUTPUT  SECTION  .  FILE-CONTROL  . 

<f ile-control-list>  <ic> 

16  i  <empty> 

17  <file-control-list>  ::=  <f ile-control-entry> 

!  <file-control-list> 

<file-control-entry> 

19  <file-control-entry>  ::=  SELECT  <id>  <attribute-list>. 

At  this  point  all  of  the  information   about   the   file 
has  been   collected  and   the  type  of  th<*   file  can  be 
determined.   File  attributes  are  checked  for 
compatabili ty  and  entered  in  the  symbol  table. 

20  <attribute-list>  ::=  <one  attrib> 

21  !  <attribute-list>  <one  attrlb> 

22  <one-attrib>  : :=  ORGANIZATION  <org-type> 
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23  j  ACCESS  <acc-type>  <relatives' 

24  !  ASSIGN  <input> 

A  file  control  block  is  built  for  the  file  using  the 
INT  operator. 

25  <or?-type>  ::=  SEQUENTIAL 

No  information  needs  to  be  stored   since   the  default 
file  organization  is  sequential. 

26  |  RELATIVE 

The  relative  attribute  is  saved  for  production  19. 

27  <acc-type>  : :=  SEQUENTIAL 

This  is  the  default. 

28  !  RANDOM 

The  random  access  mode  is  saved  for  production  19. 

29  <relative>  ::=  RELATIVE  <id> 

The  pointer  to  the  identifier  will  be  retained  by 
the  current  symbol  pointer,  so  this  production  only 
saves  a  flag  on  the  value  stac'x  indicating  that  the 
production  did  occur. 

30  !    <empty> 

31  <ic>    ::=   I-O-CONTROL    .    <same-list> 

32  !    <empty> 

33  <same-list>  ::=  <same-element> 

34  !  <same-list>  <same-element> 

35  <same-element>  : :=  SAME  <id-string>  . 

36  <id-string>  : :=  <id> 

37  |  <id-string>  <id> 

38  <d-div>  ::=  DATA  DIVISION  .  <f ile-sect ion)  <vork> 


<link> 

39  <file-section>  ::=  FILE  SECTION  .  <file-llst> 

A  flag  needs  to  be  set  to  indicate  completion  of 
the  file  section,  so  that  the  appropriate  routine 
will  be  called  when  parsing  level  entries  in  the 
WORKING  STORAGE  SECTION. 

40  !  <empty> 

The  flag,  indicated  in  production  39,  is  set. 

41  <file-list>  ::=  <f i le-elemen t> 

42  !  <file-list>  <f ile-element> 

43  <files>  ::=  FD  <id>  <file-control>  . 

<record-description> 

This  statement  indicates  the  end  of  a  record 
description,  if  there  was  an  implied  redefinition 
of  the  record,  then  the  level  stack  (IDSSTACS) 
must  be  reduced.   The  length  of  the  first  record 
description  and  its  address  can  now  be  loaded 
into  the  symbol  table  for  the  file  name. 

44  <file-control>  : :=  <flle-list> 

The  address  of  the  symbol  table  entry  for  the 
record  describing  the  file  name  is  enterei  into  an 
attribute  of  the  file  name  symbol  table  entry, 
while  the  address  of  the  file  names  symbol  table 
entry  is  entered  into  an  attribute  of  the  same 
record . 

45  I  <empty> 
Same  as  44  above. 
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4:6  < file-list >  ::=  <f i le-element> 
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<flle-list>  <f ile-element> 


48  <file-element>  : :=  BLOCK  <integer>  RECORDS 

49  !  RECORD  <rec-count> 

The  record  length  is  saved  for  comparison  with 
the  calculated  length  from  the  picture  clauses. 


50 
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LABEL  RECORDS  STANDARD 
LABEL  RECORDS  OMITTED 
VALUE  OF  <id-string> 


53  <rec-count>  ::=  <integer> 
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<integer>  TO  <integer> 


The  TO  option  is  the  only  indication  that  the  file 
will  he  variable  length.  The  maximum  length  roust  he 
saved . 

55  <work>  ::=  WORKING-STORAGE  SECTION  .  <record-description> 

If  the  level  stack  (ID^STACK)  contains  a  record 
identifier  with  a  level  number  greater  than  one, 
then  the  stack  must  be  reduced.   The  reduction 
depends  on  whether  the  identifier  on  the  top  of 
the  stack  is  a  redefinition  of  the  item  beneath 
it  or  not.   The  primary  action  is  to  assign  the 
proper  amount  of  storage  to  the  last  record  in 
the  WORKING  STORAGE  SECTION. 

56  !  <empty> 

57  <link>  ::=  LINKAGE  SECTION  .  <record-descriot i on> 
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<empty> 


59  <record-descriotion>  ::=  <level-entry> 


37 


60  !  <  record -descnption><level-entry> 

61  <level-entry>  ::=  <integer>  <data-id>  <redefines> 

<data-type>  . 
The  symbol  table  address  for  the  level  entry 
identifier  is  loaded  into  the  level  stack 
(ID$STACK).   The  level  stack  Keeps  track  of  the 
nesting  of  field  definitions  (elementary  items) 
in  a  record  in  the  FILE  and  WORKING  STORAGE 
SECTIONS.   At  this  point  there  may  be  no  infor- 
mation about  the  length  of  the  item  being  defined 
and  its  attributes  may  depend  entirely  upon  its 
constituent  fields.   Within  the  EILE  SECTION, 
multiple  record  descriptions  for  a  file  are 
assumed  to  be  redefinitions  of  the  first  record 
description.   In  the  WORKING  STORAGE  SECTION,  if 
there  is  a  VALUE  CLAUSE,  the  stack  level  to  which 
it  applies  is  saved  in  PENDING* LITERAL,  the  level 
entry  number  is  saved  in  VALUE$LEVEL  and  a  fla*, 
VALUE$FLAG,  is  set. 

62  <data-id>  ::=  <id> 

63  !  FILLER 

An  entry  is  built  in  the  symbol  table  to  record 
information  about  this  record  field.   It  cannot  be 
used  explicitly  in  a  program  because  it  has  no  name, 
but  its  attributes  will  need  to  be  stored  as  part  of 
the  total  record. 

64  <redefines)  : :=  REDEFINES  <id> 
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The  redefines  option  gives  new  attributes  to  a 
previously  defined   record  area.   The  symbol  table 
pointer  to  the  area  being  redefined  is  saved  in  an 
attribute  of  the  redefining  identifier's  symbol  table 
entry,  so  that  information  can  be  transferred  to  the 
area  by  either  identifier.  In  addition  to  the  inform- 
ation saved  relative  to  the  redefinition,  it  is  nec- 
essary to  check  to  see  if  the  current  identifier's 
level  number  is  less  than  or  equal  to  the  level  number 
of  the  identifier  currently  on  the  top  of  the  level 
stack.   If  this  is  true,  then  all  information  for  the 
item  on  top  of  the  stack  has  been  saved  and  the  stack 
can  be  reduced.   If  the  current  identifier  is  a  redef- 
inition of  another  identifier,  the  stack  entry  for  the 
record  being  redefined  is  not  removed  until  the  first 
non-redefinition  of  a  current  identifier  at  the  same 
level . 
65  !  <empty> 

As  in  production  64,  the  stack  (ID$STAC!)  is  checked 
to  determine  if  the  current  level  number  indicates  a 
reduction  of  the  level  stack  is  necessary.   In  add- 
ition, special  action  needs  to  be  taken  if  the  new 
level  is  01.   If  an  01  level  is  encountered  at  this 
production  prior  to  production  39  or  40  (the  end  of 
the  file  area),  it  is  an  implied  redefinition  of  the 
previous  01  level  record.   In  the  WORKING  STORAGE 
SECTION,  it  indicates  the  start  of  a  new  record. 
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66  <data-type>    ::=   <prop-list> 

67  j    <empty> 

68  <prop-list>    ::=   <data-elemen t> 

69  !  <prop-list>  <data-element> 

70  <data-element>  : :=  PIC  <input> 

The  <input>  at  this  point  is  the  character  string 
that  defines   record  field.   It  is  analyzed  and  the 
necessary  extracted  information  is  stored  in  the 
symbol  table. 

71  !  USAGE  COMP 

The  field  is  defined  to  a  "binary  field;  however, 
COMP  has  not  been  implemented,  therefore,  if 
there  is  an  associated  VALUE  CLAUSE,  the  value  is 
entered  into  the  associated  identifier's  value 
storage  location  in  display  format. 

72  !    USAGE   DISPLAY 

The  DISPLAY  format  is  the  default,  And    thus  no 
special  action  occurs. 

73  j  SIGN  LEADING  <separate> 

This  production  indicates  the  presence  of  a  sign  in 
a  numeric   field.    The   sign  will  be  in  a  leading 
position.   If  the  <separate>  indicator  is  true, 
then  the  length  will  be  one  longer  than  the  PICTURE 
CLAUSE,  and  the  type  will  be  changed  to  signed 
numeric  leading  and  separate. 

74  !  SIGN  TRAILING  <separate> 

The  same  information  required  by  production  73  must 
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be  recorded,  but  in  this  case  the  sign  is  trailing 
rather  than  leading. 

75  !  OCCURS  <integer> 

The  type  must  he  set  to  indicate  multiple 
occurrences  and  the  number  of  occurrences  saved 
for  commuting  the  space  defined  by  this  field. 

76  !  SYNC  <direction> 
Syncronization  with  a  natural  boundary  is  not 
required  by  this  machine. 

77  |  VALUE  <literal> 

The  field  being  defined  will  be  assigned  an  initial 
value  determined  by  the  value  of  the  literal  through 
the  use  of  an  INT  operator.   This  is  only  valid  in 
the  WORKING-STORAGE  SECTION.   Note  that  numeric  and 
signed  numeric  PICTURE  CLAUSES  will  have  a  numeric 

—  no  quotes  delimiting  —  VALUE  CLAUSE,  while 
alphanumeric  and  alpha  types  will  have  a  nonnumeric 

—  literal  delimited  with  quotes  —  VALUE  CLAUSE. 
73   <direction>  ::=  LEFT 

79  i  RIGHT 

90  !  <empty> 

81  <separate>  : :=  SEPARATE 

The  separate  sign  indicator  is  set. 

82  !  <empty> 

83  <literal>  :  :=  <input> 

The  input  string  is  checked  to  see  if  it  is  a  valid 
numeric  literal,  and  if  valid,  it  is  stored  to  be 
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used    in    a   value   assignment. 

84  !  <lit> 

This  literal  is  a  quoted  string. 

85  !  ZERO 

As  the  case  of  all  literals,  the  fact  that  there 
is  a  pending  literal  needs  to  be  saved.   In  this 
case  and  the  three  following   cases,  an   indicator 
of  which  literal   constant   is   "being   saved  is 
all  that  is  required.   The  literal  value  can  he 
reconstructed  later. 

86  !  SPACE 
37  !  QUOTE 

88  <integer>  ::=  <input> 

The  input  string  is  converted  to  an  integer  value 
for  later  internal  use. 

39   <id>  ::=  <input> 

The  input  string  is  the  name  of  an  identifier   and 
is  checked  aginst  the  symbol  table.   If  it  is  m  the 
symbol  table,  then  a  pointer  to  the  entry  is   saved. 
If  it   is  not  in  the  symbol  table,  then  it  is 
entered  and  the  address  of  the  entry  is  saved. 

D.   INTERFACE  ACTIONS 

When  compilation  is  suspended  in  PART  ONE  of  the 
compiler  certain  feey  variables  are  saved  for  use  in  PART 
TWO.  These  variables  are  declared  sequentially  in  PART  ONE 
and   are   therefore   located   in   contiguous   memory   in  the 
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variable  area  of  PART  ONE.  These  variables  consist  of 
debugging  toggles  set  when  invoking  the  compiler  ,  i.e. 
sequence  or  token  numbers,  a  pointer  to  the  next  available 
address  in  the  symbol  table,  a  pointer  to  the  next  character 
in  the  input  source  file,  the  output  file  control  block,  the 
next  address  in  the  intermediate  code  area,  the  next  address 
in  the  constants  area,  and  the  base  address  of  the  symbol 
table.  These  key  variables,  consisting  of  48  bytes,  are 
copied  to  the  48  bytes  immediately  below  the  IREADER  routine 
to  insure  they  are  not  destroyed  when  PART  TWO  of  the 
compiler  is  brought  into  memory.  Since  the  memory  area 
required  for  PART  ONE  is  larger  than  that  required  by  PART 
TWO  the  symbol  table  does  not  need  to  be  relocated.  Since 
the  symbol  table  is  not  altered  when  PART  TWO  of  the 
compiler  is  brought  into  memory  only  the  base  address  of  the 
symbol  table  and  the  last  address  of  the  symbol  table  need 
be  saved  to  insure  that  access  to  the  symbol  table  can  be 
continued  in  PART  TWO.  See  Figure  [II-9]  for  an  Illustration 
of  the  memory  organization  when  control  is  transfered  from 
PART  ONE  to  IREADER.  The  IP.EADEP  rountine  causes  PART  TWO  of 
the  compiler  to  be  brought  into  memory  starting  at  130E  and 
then  transfers  control  to  PART  TWO  of  the  Compiler. 

E.   COMPILER  MCIULE  "PART  TWO" 
1 .   Purpose 

The  second  part  of  the  compiler  scans  ani  parses  the 
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MICR0-CC3CL  source  statements  starting   with   the   PROCEDURE 
DIVISION  and  generates  the  necessary  intermediate  code. 

2.  Control  Actions 

The  first  action  after  control  is  transfered  to  PART 
TWO  from  the  IREADER  routine  is  to  copy  the  48  bytes  of  the 
information  saved  from  PART  ONE  into  associated  variables  in 
PART  TWO.  After  these  variables  are  initialized  all 
references  to  files,  symbol  table  entries,  etc.  can  be  made 
in  PART  TWO  and  compilation  can  continue.  See  Figure  [11-10] 
for  an  illustration  of  the  memory  organization  at  the  time 
PART  TWO  begins  compilation. 

3.  Symbol  Table  Entries 

Entries  made  in  the  symbol  table  by  PART  TWO  will  be 
those  for  paragraph  labels  encountered  within  the  PROCEDURE 
DIVISION  of  the  source  program. 

4.  Intermediate  Code  Generation 

?or  an  explanation  of  the  pseudo-instructions  that 
are  generated  by  PART  TWO  refer  to  the  compiler  program 
listings  and  the  parser  actions  below.  Also,  for  general 
information  on  pseudo-instructions  refer  to  section  III-D. 
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5.   Parser  Actions 

The  actions  corresponding  to  each  parse  step  in  PART 
TWO  are  explained  below.  In  each  case,  the  grammar  action 
that  is  being  applied  is  given,  and  an  explanation  of  what 
program  actions  take  place  for  that  step  has  been  included. 
In  describing  the  actions  taken  for  each  parse  step  there 
has  been  no  attempt  to  describe  how  the  symbol  table  entries 
are  made,  what  pseudo  instructions  are  generated  or  how  the 
values  are  preserved  on  the  stack.  The  intent  of  this 
section  is  to  describe  what  information  needs  to  be  retained 
and  at  what  point  in  the  parse  it  can  be  determined.  Where 
no  action  is  required  for  a  given  statement,  or  where  the 
only  action  is  to  save  the  contents  of  the  top  of  the  stack, 
no  explanation  is  given. 

1  <p-div>  ::=  PROCEDURE  DIVISION  <using>  . 

<proc-body>  EOF 
This  production  indicates  termination  of  the 
compilation.    If   the   program  has  sections,  then 
it  will  be  necessary  to  terminate  the  last  section 
with  a  RET  0  instruction.    The  code  will  be  ended 
by  the  output  of  a  TEE  operation. 

2  <using>  ::=  USING  <id-string> 

Not  implemented. 

3  !    <empty> 

4  <id-string>    : :=   <id> 

The    identifier    stack    is    cleared   and    the      symbol 
table   address      of      the      identifier      is    loaded    into 
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the  first  stack  location. 

5  !    <id-string>  <id> 

The  identifier  stack  is   incremented   and   the   symbol 
table  pointer  stacked. 

6  <proc-body>  ::=  <paragraph> 

7  !  <proc-body>  <paragraph> 

8  <paragraph>  ::=  <id>  .  <sentence-list> 

The  starting  and  ending  address  of  the   paragraph 
are  entered  into  the  symbol  table.   A  return  is 
emitted  as  the  last  instruction  in  the  paragraph 
(RET  0).   When  the  label  is  resolved,  it  may  be 
necessary  to  produce  a  BST  operation  to  resolve 
previous  references  to  the  label. 

9  !  <id>  SECTION  . 

The  starting  address  for  the  section  is  saved.   If 
it  is  not  the  first,  then  the  previous 
section  ending  address  is  loaded  and  a  return 
(RET  0)  is  output.   As  in  production  6,  a  3ST  may 
be  produced. 

10  <sentence-list>  ::=  <sentence>. 

11  !  <sentence-lis t>  <sentence>  . 

12  <sentence>  ::=  <imperative> 

13  !  <conditional> 

14  i  ENTER  <id>  <opt-id> 

This  construct  is  not  implemented.  An  ENTER  allows 
statements  from  another  language  to  inserted  in  the 
source  code. 
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15  <imperative>  :  :=  ACCEPT  <subid> 

ACC  <address>  <length> 

16  I  <arithmetic> 

1?  !  CALL  <lit>  <using> 

This  is  not  implemented. 

18  !  CLOSE  <ld> 

CLS  <file  control  block:  address> 

19  !  <file-act> 

20  !  DISPLAY  <lit/id>  <opt-lit/id> 
The  display  operator  is  produced  for  the  first 
literal  or  identifier  (DIS  <address>  <length>  <flag>). 
If  the  second  value  exists,  the  same  code  is  also 
produced  for  it.  The  only  difference  in  the  two 
display  outputs  is  the  flag  is  set  to  zero  on  the 
first  display  to  surpress  the  carriage  return  and 
line  feed. 

• 

21  !    EXIT   <program-id> 
RET    0 

22  !    GO   <id> 
BRN  <address> 

23  i    GO   <id-string>   DEPENDING   <id> 

GDP   is    output,    followed    by      a      number      of      parameters: 

<the   number      of   entries    in   the    identifier    stack> 
<the    length   of   the  depending    identified     <the 
address    of    the     depending      identifier^    'the   address 
of   each    identifier    in    the    stack>. 
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24 


25 


26 


27 

23 


j  MOVE  <lit/id>  TO  <subid> 
The  types  of  the  two  fields  deterrir.e  the  ^ove  that 
is  generated.   Numeric  moves  go  through  register  two 
using  a  load  and  a  store.   Non-numeric  moves  deper.i 
upon  the  result  field  and  may  he  either  MOV,   MED   or 
MNE.   Since  all   of   these  instructions  have  long 
parameter  lists,  they  have  not  been  listed  in 
detail. 

!  OPEN  <type-action>  <id> 
This  produces  either  OPN,  0?1 ,  or  0P2  depending 
upon  the  <type-acti on> .   Each  of  these  is  followed 
by  file  control  "block  address. 

i  PERFORM  <id>  <thru>  <finish> 
The  PER  operation  is  generated  followed  by  the 
<branch  address>  <the  address   of  the  return 
statement  to  be  set>  and  <the  next  instruction 
address>  . 

!  <read-id> 


j  STOP  <terminate> 
If  there  is  a  terminate  message,  then  STD  is 
produced  followed   by  <message  address>  <message 
length>.   Otherwise  ST?  is  emitted. 

29  <conditional>  ::=  <arithmetic>  <size-error>  ^i^erati  vex 

A  3ST  operator  is  output  to  complete  the  branch  around 
the  imperative  from  production  65. 

30  !  <file-act>  <invalid>  <imperative> 

A  3ST  operator  is  output  to  complete  the  branch  fron 
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production  64. 

31  !  < if-nonterminal>  <condttion>  <action> 

ELSE  <imperative> 
NEG  will  be  emmitted  unless  <condition>  is  a 
"NOT  <cond-type>" ,  in  which  case  the  two  negatives 
will  cancel  each  other.   Two  3ST  operators  are  required 
The  first  fills  in  the  branch  to  the  ELSE  action.   The 
second  completes  the  branch  around  the  <im?erative> 
which  follows  ELSE. 

32  !  <read-id>  <s?ecial>  <imperativp> 

A  BST  is  produced  to  complete  the   branch   around   the 
<imperat  ive>. 

33  <Arithmetic>  ::=  ADD  <l/id>  <opt-l/ld>  TO  <subid> 

<round> 
The  existence  of  multiple  load  and  store  instructions 
ma£e  it  difficult  to  indicate  exactly  what  code  will 
be  generated  for  any  of  the  arithmetic  instructions. 
The  type  of  load  and  store  will  depend  on  the  nature 
of  the  number  involved,  and  in  each  case  the  standard 
parameters  will  be  produced.  This  parse  step  will  in- 
volve the  following  actions:  first,  a  load  will  be  em- 
itted for  the  first  number  into  regster  zero.  If 
there  is  a  second  number,  then  a  load  into  register 
one  will  be  produced  for  it,  followed  by  an  ADD  and  a 
STI.  Next  a  load  into  register  one  will  be  generated 
for  the  result  number.  Then  an  ADD  Instruction  will 
be  emitted.   Finally,  if  the  round  indicator  is  set,  a 
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END  operator  will  be  produc°d  prior  to  the  store. 

34  !  DIVIDE  <l/id>  INTO  <subid>  <round> 
The  first  number  is  loaded  into   register   zero.   The 
second   operand   is   loaded   into  register  one.   A  DIV 
operator  is  generated,  followed  by  a  RND  operator  prioi 
to  the  store,  if  required. 

35  !  MULTIPLY  <l/id>  BY  <subid>  <round> 
The  multiply  is  the  same  as  the  divide  except  that  a 
MUL  operator  is  generated. 

36  ,'  SUBTRACT  <l/id>  <opt-l/id>  FROM 

<subid>   <round> 
Subtaction   generates    the   same   code   as    the      ADD      except 
that   a   SUB    is    produced    in   place    of    the   last    .-DD. 
3?      <file-act>    : :=   DELETE   <id> 

Either   a   TLS    or   a   DLR  will    be   produced   along   with      the 
required    parameters. 

38  !  REWRITE  <id> 

Either  a  RWS  or  a  RWR  is  emitted,  followed  by  parame- 
ters. 

39  !  WRITE  <id>  <specia 1-ac t > 

There  are  four  possible  write  instructions:  WTE,  WV1, 
WRS,  and  WRR. 
4=0  <condition>  ::=  <li  t>  <not)  <cond-type> 

One  of  the  compare  instructions  is  produced.   They  are 
CAL,   CNS,  CNU,  RGT,  RLT,  REO,  SST,  SLT,  and  SIC. 
Two  load  instructions  and  a  SU"?  will  also  be  generated 
if  one  of  the  register  comrarisons  is  reauired. 
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41  <cond-type>  ::=  NUMERIC 

42  !  ALPHABETIC 

43  !  <compare>  <lit/id> 

44  <not>  : :=  NOT 

NEG  is  emitted  unless  the  MOT  is  part  of  an  I? 
statement  in  which  case  the  NEG  in  the  I? 
statement  is  cancelled. 

45  !  <empty> 

46  <compare>  ::=  GREATER 

47  i  LESS 

48  !  EQUAL 

49  <E0UND>  : :=  ROUNDED 

50  !  <empty> 

51  <terminate>  ::=  <literal> 

52  |  RUN 

53  <special>    ::=   <invalid> 

54  !    END 

An  ERO  operator  is  emitted  followed  by  a   zero.   The 
zero  acts  as  a  filler  in  the  cole  and  will  be  back- 
stuffed  with  a  branch  address.  In  this  production 
and  several  of  the  following,  there  is  a  forward 
branch  on  a  false  condition  past  an  inperativ0  action. 
For  an  example  of  the  resolution,  examine  production  32 

55  <opt-id>  :  :=  <subid> 

56  I  <empty> 

57  <action>  :  :=  <imperative> 

BRN  0 
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53  !  NEXT  SENTENCE 

ERN  0 

59  <thru>  : :=  THRU  <id> 

60  I  <empty> 

61  <fmish>    :  :=    <l/id>   TIMES 

LDI  <address>  <len*th>  DEC  0 

62  !  UNTIL  <condition> 

63  !  <empty> 

64  <invalid>  ::=  INVALID 

INV  0 

65  <size-error>  ::=  SIZE  EP.ROB 

SER  0 

66  <special-act>    ::=  <vhen>   ADVANCING   <how-many> 

67  !    <empty> 
63      <when>    : :=   BEFORE 

69  !    AFTER 

73  <hcv-many> : :=  <integer> 
71  j  PAGE 

74  !  1-0 

75  <subid>  ::=  <subscript> 

76  !  <id> 

77  <integer>  ::=  <in?ut> 

The  value  of  the  input  string  is  saved  as  an  internal 
number . 
7e   <id>  : :  =  <innut> 

The  identifier  is  checked  aginst  the  symbol  table,  if 
it   is  not  present,  it  is  entered  as  an  unresolved 


54 


79 


80 
SI 
32 


label. 
<l/id>  : :=  <mput> 

The  input  value  may  be  a  numeric  literal.   If   so,   it 
is   placed   in   the  constant  area  with  an  INT  operand. 
If  it  is  not  a  numeric  literal,  then   it   must   be   an 
identifier,  and  it  is  located  in  the  symbol  table. 
!  <subscript> 


j  ZERO 


83 
84 

85 


96 
37 

88 
89 


90 
91 
92 


<subscript>  ::=  <id>  (  <input>  ) 

If  the  identifier  was  defined  with  a  USING-   option, 
then   the   input   string  is  checked  to  see  if  it  is  a 
number  or  an  identifier.   If  it  is  an  identifier, 
then  an  SCR  operator  is  produced. 
<opt-l/id>  : :=  <l/id> 

!  <empty> 
<nn-lit>  : :=  <lit> 

The  literal  string  is  placed  into   tne   constant   area 
using  an  INT  operator. 
!  SPACE 
!  QUOTE 
<literal>  ::=  <nn-lit> 
!  <input> 
The  input  value  must  be  a  numeric  literal  to  be  valid 
and  is  leaded  into  the  constant  area  using  an  INT. 
!  ZERO 

<lit/id>  : :=  <l/id> 

!  <nn-lit> 
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93  < opt-li t/il>  ::=  <lit/id> 

94  !  <empty> 

95  <program-id>  ::=  <id> 

96  !  <empty> 

97  <read-id>  ::=  READ  <id> 

There  are  four  read  operations:  RDY ,      RVL,   RRS ,   and 
RRP. 

93  <if-nonterminal>::=I7 
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Ill .      NPS    MICRO-COBOL    INTERPRETER 

A.   GENERAL  DESCRIPTION 

The  following  sections  describe  the  NPS  MICRO-COBOL 
pseudo-machine  in  terms  of  the  implementation ,  memory 
organization,  interface  actions  and  interpreter 
instructions.  The  pseud o-machinp ,  which  is  constructed  in 
the  transient  program  area  of  CP/M,  is  the  target  machine 
for  the  compiler  and  is  implemented  through  a  programmed 
interpreter.  The  interpreter  decodes  each  operation  and 
either  calls  subroutines  to  perform  the  required  actions  or 
acts  directly  on  the  run  time  environment  to  control  the 
actions  of  the  interpreter.  All  communications  "between 
instructions  is  done  through  common  areas  in  the  program 
where  information  can  be  stored  for  later  use.  See  figure 
CI  1 1— 11  for  an  illustration  of  the  pseudo-machine 
organi  za  ti  on . 

The  machine  contains  a  program  counter  and  multiple 
parameter  operations  which  contain  all  the  information 
required  to  perform  one  complete  action  required  by  the 
language.  Three  eighteen  digit  registers  are  used  for 
arithmetic  operations,  along  with  a  subscript  stac*  used  to 
compute  subscript  locations,  and  a  set  of  flags  are  used  tc 
pass  branching  information  from  one  instruction  to  another. 

Addresses  in  the  pseudo-machine  are  represented  by  16 
bit   values.   Any  memory  address  greater  than  23  hexideci-ai 
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is  valid.  Addresses  less  than  2?  hexidecimal  will  be 
interpreted  as  having  special  significance.  For  example 
addresses  one  through  eight  are  reserved  for  subscript  stack 
references.  All  other  addresses  in  the  machine  are  absolute 
addresses . 

The  registers  allow  manipulation  of  signed  numbers  up  to 
eighteen  digits  in  length.  Included  in  their  representation 
is  a  sign  indicator  and  the  position  of  the  assumed  decimal 
point  for  the  currently  loaded  number.  Numbers  are 
represented  in  standard  CCEOL  "Display"  format.  These 
numbers  may  have  separate  signs  indicated  by  "+"  and  "-'  or 
may  have  a  "zone"  indicator,  denoting  a  negative  sign,  in 
the  most  significant  byte  of  a  number's  storage  location. 
Before  operations  occur  on  any  number,  it  is  converted  to  a 
packed  decimal  format  and  entered  into  one  of  the 
pseudo-machine  registers. 

B.   MEMORY  ORGANIZATION 

The  memory  of  the  pseudo-machine  is  divided  into  three 
major  areas:  1.)  the  data  area  is  established  by  the  DATA 
DIVISION  statements  of  the  source  program,  2.)  the  constants 
area  which  is  established  by  both  the  DATA  and  PROCEDURE 
DIVISIONS  of  the  source  program,  and  3.)  the  code  area  which 
is  established  by  the  PROCEDURE  DIVISION. 

The  data  area  is  the  lowest  area  in  the  pseudo-machine. 
This  area  contains  the  storage  for  identifiers  declared  in 
the   DATA  DIVISION.  Additionally,  the  data  area  contains  the 
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File  Control  Block  (FC3)  and  the  buffer   s?ac°   (123   bytes) 
for  all  files  declared  in  the  source  program. 

Immediately  following  the  data  area  is  the  code  area. 
This  contiguous  area  of  storage  contains  all  executable  cole 
generated.  The  constants  area  is  located  in  high  memory  of 
the  pseudo-machine.  This  area  contains  all  edit  field  mas.-cs 
as  well  as  all  numeric  and  non-numeric  literals.  Figure 
[III-l]  ilustrates  the  memory  organization  of  the 
pseudo-machine . 
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PSEUD0-MACRIN2  ORGANIZATION 
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C.   INTERPRETER  INTERFACE 

The  interpreter  consists  of  two  interface  routines  and 
the  main  interpreter  program.  To  execute  the  interpreter  the 
command  EXEC  <f ilename .f iletype>,  (where  file  type  is  CIS), 
is  typed  at  the  terminal.  This  action  causes  the  two 
interface  routines,  BUILD  and  INTRDR,  tc  be  brought  into 
memory.  See  figure  [II 1—2]  which  illustrates  the  memory 
organization  immediately  after  3UILD  and  INTRDR  nave  been 
copied  into  memory.  The  BUILD  routine  reads  in  the 
intermediate  code,  initializes  all  memory  locations 
requiring  initalization ,  and  resolves  all  unresolved  address 
references.  The  INTRDR  routine  reads  the  interpreter  program 
into  memory  and  transfers  control  to  the  interpreter 
program. 

The  intermediate  code  instructions  fall  into  two 
categories:  1.)  instructions  used  by  3UILD  to  establish  the 
run  time  environment  and,  2.)  instructions  to  be  executed  by 
the  interpreter.  The  following  four  instructions  are 
generated  in  tbe  compiler  for  use  by  the  BUILD  routine;  SCD, 
INT,  BST,  and  TER. 

The  SCD  (start  code)  instruction  is  the  last  instruction 
generated  by  PART  ONE  and  indicates  where  the  first 
executable  instruction  for  the  intermediate  code  is  to  be 
loaded.  This  corresponds  to  the  address  immediately 
following  the  data  area  in  the  pseudo-machine.  See  Figure 
[III-l]  which  illustrates  the  relative  location  of  the 
address  that  is  associated  with  the  SCD  instruction. 
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MEMCRY  ORGANIZATION  AFTER  3UILD  AND  INTRBR 
HAVE  BEEN  LOADED  INTO  MEMCRY 
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The  INT  (initialize)  instruction  causes  the  BUILD 
routine  to  initialize  the  data  area  with  the  values 
associated  with  those  identifiers  in  thp  DATA  DIVISION  of 
the  source  program  that  had  VALUE  CLAUSES.  In  addition,  the 
INT  instruction  causes  the  BUILD  routine  to  initialize  the 
constants  area  with  all  the  edit  masks  for  those  identifiers 
of  the  numeric  and  alphanumeric  edit  type,  and  all  literals 
encounted  in  the  PROCEDURE  DIVISION  of  the  source  program. 

The  BST  (backstuff)  instruction  resolves  all  unresolved 
references,  i.e.  branches  to  labels  defined  after  the 
respective  PERFORM  or  GO  statement  was  encountered  in  the 
source  program. 

The  TER  (terminate)  instruction  is  the  last  instruction 
generated  by  PART  TWO  of  the  compiler  and  indicates  the  end 
of  the  intermediate  code  file.  Upon  encountering  a  TER 
instruction  in  the  intermediate  code  the  BUILD  routine 
inserts  a  ST?  instruction  in  its  place.  The  ST?  instruction 
will  cause  the  interpreter  to  terminate  interpretation  of 
the  program  when  encountered. 

All  other  code  generated  by  the  compiler  is  copied  into 
the  code  area  of  the  pseudo-machine  by  the  BUILD  routine. 
See  Figure  [II 1—3]  for  an  illustration  of  the  memory 
organization  at  this  point  in  the  initialization  routine. 
The  final  action  taken  by  the  ^UILD  routine  is  tc  move  the 
INTPDR  routine  into  the  input  buffer  at  80H  and  transfer 
control  to  INTRDR.  This  frees  the  area  from  100E  to  the  base 
of  the  data  area  for  the  interpreter. 
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The  INTRDR  routine  reads  the  interpreter  program  Into 
memory  starting  at  100H  and  transfers  contol  to  it.  7rom 
this  point  on  the  interpreter  program  executes  the 
intermediate  code  that  was  loaded  into  the  pseudo-machine. 
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MEMORY  ORGANISATION  AFTER  INTERMEDIATE  CODE  IS 
LOADED  INTO  MEMORY  AND  BEFORE  THE  INTERPRETER 
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D.   PSEUDO-MACHINE  INSTRUCTIONS 

This  section  briefly  covers  the  pseudo-machine 
instructions  used  in  the  interpreter,  their  format,  and  the 
actions  which  they  accomplish. 

1 .  Format 

All  of  the  interpreter  instructions  consist  of  an 
instruction  number  followed  by  a  list  of  parameters.  Tne 
following  sections  describe  the  instructions,  list  the  re- 
quired parameters,  and  describe  the  actions  taken  by  the 
machine  in  executing  each  instruction.  In  each  case,  parame- 
ters are  denoted  informally  by  the  parameter  name  enclosed 
in  brackets.  The  BRN  branching  instruction,  for  example, 
uses  the  single  parameter  Ooranch  address^  which  is  the  tar- 
get of  the  unconditional  branch. 

As  each  instruction  number  is  fetched  from  memory, 
the  program  counter  is  incremented  by  one.  The  program 
counter  is  then  either  incremented  to  the  next  instruction 
number,  or  a  branch  is  taken. 

The  three  eighteen  digit  registers  which  are  used  by 
the   instructions   covered  in  the  following  sections  are  re- 
ferred to  as  registers  zero,  one,  and  two. 

2 .  Arithmetic  Operations 

There  are  five  arithmetic  instructions  which  act 
upon  the  three  registers.  In  all  cases,  the  result  is 
placed  in  register  two.   Operations  are  allowed   to   destroy 
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the  input  values  during  the  process  of  creating  a  result, 
therefore,  a  number  loaded  into  a  register  is  not  available 
for  a  subsequent  operation. 

ADD:  (addition).  Sum  the  contents  of   register   zero 
and  register  one. 
Parameters:   no  parameters  are  required. 

SUB:  (subtract).  Subtract  register  zero  from  register 
one . 
Parameters:   no  parameters  are  required. 

MUL:  (multiply).  Multiply  register  zero  by  register 
one . 
Parameters:   no  parameters  are  required. 

DIV:  (divide).   Divide  register  one  by  the  value   in 
register  zero.   The  remainder  is  not  retained. 
Parameters:   no  parameters  are  reouired 

RND:(round).  Round  register  two  to  the  last  signifi- 
cant decimal  place. 
Parameters:   no  parameters  are  required. 

3 .   Branching 

The  machine  contains  the   following  flags  which  are 
used  by  the  conditional  instructions  in  this  section. 

BRANCH  flag  —  indicates  if  a  branch  is  to  be  taken? 

END  OF  RECORD   flag  —  indicates  that  an   end   of 
input  condition  has  been  reached  when  an  attempt  was  made 
to  read  input; 

OVERFLOW  flag  —  indicates  the  loss  of  information 
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from  a  register  due  to  a  number  exceeding  the  available 
size; 

INVALID  flag  —   indicates  an  invalid  action  in 
writing  to  a  direct  access  storage  device. 

All  of  the   branch   instructions   are   executed   by- 
changing  the  value  of  the  program  counter.   Some  are  uncon- 
ditional  branches  and  some  test  for  condition  flags  which 
are  set  by  other  instructions.   A  conditional  branch  is  exe- 
cuted  by   testing   the   branch  flag  which  is  initialized  to 
false.   A  true  value  causes  a  branch  by   changing   the   pro- 
gram counter  to  the  value  of  the  branch  address.   The  branch 
flag  is  then  reset  to  false.  A  false  value  causes   the   pro- 
gram  counter   to   be  incremented  to  the  next  sequential  in- 
struction. 

BRN :      (branch  to  an  address).   Load   the   program 
counter  with  the  <branch  address>. 
Parameters:   <branch  address> 

The  next  three  instructions  share  a  common  format. 
The  memory  field  addressed  by  the  <memory  address>  is 
checked  for  the  <address  length>,  and  if  all  the  characters 
match  the  test  condition,  the  branch  flag  is  complemented 
Parameters:  <memory  address>  <address  length>  <branch  ad- 
ires  s> 

CAL:  (compare  alphabetic).  Compare  a  memory  field 
for  alphabetic  characters. 

CNS :  (compare  numeric  signed).  Compare  a  field  for 
numeric  characters  allowing  for  a  sign  character. 
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CNU:  (compare  numeric  unsigned).  Compare  a  field  for 
numeric  characters  only. 

DEC:  (decrement  a  counter  and  branch  if  zero), 
decrement  the  value  of  the  <address  counter>  by  one;  if  tne 
result  is  zero  before  or  after  the  decrement,  the  program 
counter  is  set  to  the  <branch  address>.  If  the  result  is 
not  zero,  the  program  counter  is  incremented  by  four. 
Parameters:   <address  counter>  <branch  address) 

EOR:    (branch  on  end  of  records  flag).   If  the  end- 
of-records   flag  is  true,  it  is  set  to  false  and  the  program 
counter  is  set  to  the  <branch  address>.   If  false,  the   pro- 
gram counter  is  incremented  by  two. 
Parameters:   <branch  address> 

SDP:  (go  to  -  depending  on).  The  memory  location  ad- 
dressed by  the  <number  address>  is  read  for  the  number  of 
bytes  indicated  by  the  <memory  length/.  This  number  indi- 
cates which  of  the  ^branch  addresses)  is  to  be  used.  The 
first  parameter  is  a  bound  on  the  number  of  branch  ad- 
dresses. If  the  number  is  within  the  ranse,  the  program 
counter  is  set  to  the  indicated  address.  An  cut-of-bounds 
value  causes  the  program  counter  to  be  advanced  to  the  neit 
sequential  instruction. 

Parameters:   <bound  number  -  byte>  <memory   length)  <memory 
address)  <branch  addr-1)  <branch  addr-2)  ...  <branch  addr-n) 

INV:  (branch  if  invalid-file-action  flag  true).  If 
the  invalid-file-action  flag  is  true,  then  it  is  set  to 
false,  and  the  program  counter  is   set   to   the   branch   ad- 
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dress.   If  it  is  false,  the  program  counter   is   incremented 

by  tv  o . 

Parameters:   <branch  address> 

PER:  (perform).  The  code  address  addressed  by  the 
<change  address>  is  loaded  with  the  value  of  the  <return  ad- 
dress>.  The  program  counter  is  then  set  to  the  <branch  ad- 
dress> . 

Parameters:   <branch  address>  <change  address>   <return   ad- 
dress> 

RET:  (return).  If  the  value  of  the  <branch   address> 
is   not   zero,  then  the  program  counter  is  set  to  its  value, 
and  the  <branch  address>  is  set  to  zero.   If  the  <branch  ad- 
dress) is  zero,  the  program  counter  is  incremented  by  two. 
Parameters:   <branch  address) 

REO:  (register  equal).  This  instruction  checks  for  a 
zero   value  in  register  two.   If  it  is  zero,  the  branch  flag 
is  complemented.   A  conditional  branch  is  taken. 
Parameters:   <branch  address) 

RGT:  (register   greater   than).    "egister   two    is 
checked  for  a  negative  sign.   If  present,  the  branch  flag  is 
complemented.   A  conditional  branch  is  taken. 
Parameters:   <branch  address) 

RLT:  (register  less  than).  Register  two   is   checked 
for  a  positive  sign,  and  if  present,  the  branch  flag  is  com- 
plemented.  A  conditional  branch  is  taken. 
Parameters:   <branch  address) 

SER:  (branch  on  size  error).  If  the  overflow  flag  is 
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true,  then  the  program  counter  is  set  to  the  branch  address, 
and  the  overflow  flag  is  set  to  false.   If  it  is  false,  then 
the  program  counter  is  incremented  by  two. 
Parameters:   <branch  address> 

The  next  three  instructions  are  of   similar  form  in 
that  they   compare  two   strings  and  set  the  branch  flag  if 
the  condition  is  true. 

Parameters:   <string  addr-l>  <string  addr-2>  <length  -  ad- 
dress>  <branch  address> 

SEO:  (strings  equal).  The  condition  is  true  if  the 
strings  are  equal. 

SGT:  (string  greater  than).  The  condition  is  true  if 
string  one  is  greater  than  string  two. 

SIT:  (string  less  than).  The  condition  is  true  if 
string  one  is  less  than  string  two. 

4.   Moves 

The  machine  supports  a  variety  of  move  operations 
for  various  formats  and  types  of  data.  It  does  not  suoport 
direct  moves  of  numeric  data  from  one  memory  field  to  anoth- 
er Instead,  all  of  the  numeric  moves  go  through  the  regis- 
ters. 

The  next  seven  instructions  all  perform  the  sane 
function.  They  load  a  register  with  a  numeric  value  and 
differ  only  in  the  type  of  number  that  they  expect  to  see  in 
memory  at  the  <number  address>.  All  seven  instructions 
cause  the  program  counter  to  be  incremented  by  five.   Their 
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common   format   is  given  below. 

Parameters:   <number  address>  <byte   length>  <byte   decimal 

count>  <byte  register  to  load> 

LCD:  (load  literal).  Register  two  is  loaded  with  a 
constant  value.  The  decimal  point  indicator  is  not  set  in 
this  instruction.  The  literal  will  have  an  actual  decimal 
point  in  the  string  if  required. 

LD1 :   (load  numeric).   Load  a  numeric  field. 

LD2:  (load  postfix  numeric).  Load  a  numeric  field 
with  an  internal  trailing  sign. 

LD3:  (load  prefix  numeric).  Load  a  numeric  field 
with  an  internal  leading  sign. 

LD4:  (load  separated  postfix  numeric).  Load  a  numer- 
ic field  with  a  separate  leading  sign. 

LD5 :  (load  separated  prefix  numeric).  Load  a  numeric 
field  with  a  separate  trailing  sign. 

LD6:  (load  packed  numeric).  Load  a  packed  numeric 
field. 

MED:  (move  into  alphanumeric  edited  field).  The 
edit  ^ask  is  loaded  into  the  <to  address)  to  set  up  t:e 
move,  and  then  the  <from  address>  information  is  loaded.  The 
program  counter  is  incremented  by  ten. 

Parameters:   <to  address>  <from  address>  <length   of  move> 
<edit  mask  address>  <edit  mask  length> 

MNE:  (move  into  a  numeric  edited  field).  Tirst  the 
edit  mask  is  loaded  into  the  receiving  field,  and  then  the 
information  is  loaded.   Any  decimal  point  alignment  required 
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will  be  performed.  If  truncation  of  significant  digits  is  a 
side  effect,  the  overflow  flag  is  not  set.  The  program 
counter  is  incremented  by  twelve. 

Parameters:  <to  address>  <from  address>  <address  length  of 
move>  <edit  mask-  address>  <address  mask  length>  <byte  to  de- 
cimal count>  <byte  from  decimal  count> 

MOV:  (move  into  an  alphanumeric  field).  The  memory 
field  given  by  the  <to  address>  is  filled  by  the  from  field 
for  the  <move  length>  and  then  filled  with  blanks  in  the 
following  positions  for  the  <fill  count>. 

Parameters:  <to  address>  <from  address>  <address  move 
length>  ^address  fill  count> 

STI:  (store  immediate  register  two).  The  contents  of 
register   two   are  stored  into  register  zero  and  the  decimal 
count  and  sign  indicators  are  set. 
Parameters:   none. 

The  store  instructions  are  grouped  in  the  same  order 
as  the  load  instructions.  Register  two  is  stored  into 
memory  at  the  indicated  location.  Alignment  is  performed 
and  any  truncation  of  leading  digits  causes  the  overflow 
flag  to  be  set.  All  five  of  the  store  instructions  cause 
the  program  counter  to  be  incremented  by  four.  The  format 
for  these  instructions  is  as  follows. 

Parameters:  <address  to  store  intc>  <byte  length>  <byte  de- 
cimal count> 

STO:   'store  numeric).   Store  into  a  numeric  field. 

STI:   (store  postfix  numeric).   Store  into  a  numeric 
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field  with  an  internal  trailing  sign. 

ST2:  (store  prefix  numeric).  Store  into  a  numeric 
with  an  internal  leading  sign. 

ST3:  (store  separated  postfix  numeric).  Store  into  a 
numeric  field  with  a  separate  trailing  sign. 

ST4:  (store  separated  prefix  numeric).  Store  into  a 
numeric  field  with  a  separate  leading  sign. 

ST5:  (store  packed  numeric).  Store  into  a  packed 
numeric  field. 

5 .   Input-Output 

The  following  instructions  perform  input  and  output 
operations.  Tiles  are  defined  as  having  the  following 
characteristics:  they  are  either  sequential  or  random 
and,  in  general,  files  created  in  one  mode  are  not  required 
to  be  readable  in  the  other  mode.  Standard  files  consist 
of  fixed  length  records,  and  variable  length  files  need  not 
be  readable  in  a  random  mode.  Further,  there  must  be 
some  character  or  character  string  that  delimits  a  variable 
length  record. 

&CC :    (accept).    Read  from  the  system  input  device 
memory  at   the  location  given  by  the  <memory  address>.   The 
program  counter  is  incremented  by  three. 
Parameters:   <memory  address>  <byte  length  of  read> 

CLS :  (close).  Close  the  file  whose  file  contr-1 
block  is  addressed  by  the  <fcb  address>.  The  program  counter 
is  incremented  by  two. 
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Parameters:   <fcb  address> 

DIS :  (display).  Print  the  contents  of  the  lata  field 
pointed  to  by  <memory  address>  on  the  system  output  device 
for  the  indicated  length  and  advance  the  line  output  if 
<flag>  is  set.  The  program  counter  is  incremented  by  four. 
Parameters:   <memory  address>  <byte  length>  <flag> 

There  are  three  open  instructions  with  the  same  for- 
mat.   In  each   case,   the  file  defined  by  the  file  control 
block  referenced  will  be  opened  for  the  mode  indicated.   The 
program  counter  is  incremented  by  two. 
Parameters:   <fcb  address> 

OPN:  (open  a  file  for  input). 

QP1 :  (open  a  file  for  output). 

0P2:  (open  a  file  for  both  input  and  output).  This 
is  only  valid  for  files  on  a  random  access  device. 

The  following  file  actions  all  share  the  sane  for- 
mat. Each  performs  a  file  action  on  the  file  referenced  by 
the  file  control  block.  The  record  to  be  acted  upon  is 
given  by  the  <record  address).  The  urogram  counter  is  in- 
cremented by  six. 

Parameters:    <7C"B  address>  <record  address)  <recori  length  - 
address) . 

ELS:  (delete  a  record  from  a  sequential  file).  Re- 
move the  record  that  was  Just  read  from  the  file.  The  file 
is  required  to  be  open  in  the  input-output  mode. 

RDF:  (read  a  sequential  file).  Read  the  next  record 
into  the  memory  area. 
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WTF:  (write  a  record  to  a  seauential  file).  Append  a 
new  record  to  the  file. 

RVL:  (read  a  variable  length  record). 

WVL:  (write  a  variable  length  record). 

RWS:  (rewrite  seauential).  The  rewrite  operation 
writes  a  record  from  memory  to  the  file,  overlaying  the  last 
record  that  was  read  from  the  device.  The  file  must  be  open 
in  the  input-output  mode. 

The  following  file  actions  require  random  files 
rather  than  sequential  files.  They  make  use  of  a  random  file 
pointer  which  consists  of  a  <relative  address>  and  a  Re- 
lative length>.  The  memory  field  holds  the  number  to  be 
used  in  disk  operations  or  contains  the  relative  record 
number  of  the  last  di.sk  action.  The  relative  record  number 
is  an  index  into  the  file  which  addresses  the  record  being 
accessed.  After  the  file  action,  the  program  counter 
is  incremented  by  nine. 

Parameters:   <7CB  address>  <record  address>  <record  length  - 
address>  <relative  address>  <relative  length  -  byte>. 

DLR:  (delete  a  random  record).  Delete  the  record  ad- 
dressed by  the  relative  record  number. 

REE:  (read  random  relative).  Read  a  rardom  record 
relative  to  the  record  number. 

RRS :  (read  random  sequential).  Read  the  next  sequen- 
tial record  from  a  random  file.  The  relative  record  number 
of  the  record  read  is  loaded  into  the  memory  reference. 

RWR:  (rewrite  a  random  record). 


76 


WRR:  (write  random  relative).  Write  a  record  into 
the  area  indicated  by  the  memory  reference. 

WRS :  (write  random  sequential).  Write  the  next 
sequential  record  to  a  random  file.  The  relative  record 
number  is  returned. 

6 .   Special  Instructions 

The  remaining  instructions  perform  special  functions 
required  by  the  machine  that  do  not  relate  to  any  of  the 
previous  groups. 

NEG :  (negate).   Complement  the  value  of   the   branch 
flag. 
Parameters:    No  parameters  are  reauired. 

LDI:  (load  a  code  address  direct).   Load   the    code 
address   located   five   bytes  after  the  LDI  instruction  with 
the  contents  of  <memory  address)  after  it  has  been  converted 
to  hexidecimal. 
Parameters:    <memory  address>  <length  -  byte> 

SCR:  (calculate  a  subscript).  Load  the  subscript 
stack:  with  the  value  indicated  from  memory.  The  addr°ss 
loaded  into  the  stack  is  the  <initial  address)  plus  an 
offset.  Multiplying  the  <field  length)  by  the  number  in  the 
<memory  reference)  gives  the  offset  value. 
Parameters:  <initial  address)  <field  length)  <memory  refer- 
ence)' <memory  length)  <stack  level) 

STD:  (stop  display).  Display  the  indicated  informa- 
tion and  then  terminate  the  actions  of  the  machine. 
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Parameters:   <memory  address)  <length  -  byte> 

STP:  (stop).  Terminate  the  actions  of  the  -nachine. 
Parameters:  no  parameters  are  required.  The  following  in- 
structions are  used  in  setting  up  the  machine  environment 
and  cannot  he  used  in  the  normal  execution  of  the  machine. 

EST:  (backstuff).  Resolve  a  reference  to  a  label. 
Labels  may  be  referenced  prior  to  their  definition,  reauir- 
ins  a  chain  of  resolution  addresses  to  be  maintained  in  the 
code.  The  latest  location  to  be  resolved  is  maintained  in 
the  symbol  table  and  a  pointer  at  that  location  indicates 
the  next  previous  location  to  be  resolved.  A  zero  pointer 
indicates  no  prior  occurrences  of  the  label.  The  code  ad- 
dress referenced  by  <change  address>  is  examined  and  if 
it  contains  zero,  it  is  loaded  with  the  <new  address>.  If 
it  is  not  zero,  then  the  contents  are  saved,  and  the 
process  is  repeated  with  the  saved  value  as  the  change  ad- 
dress after  loading  the  (new  address>. 
Parameters:   <change  address)  <new  address) 

IMT:  (initialize  memory).   Load  memory  with  the  <in- 
put  string)  for  the  given  length  at  the  <memory  address). 
Parameters:    <memory  address)   <address    length)   <input 
string) 

SCD:  (start  code).  Set  the  initial  value  of  the  pro- 
gram counter. 
Parameters:   <start  address) 

TER:  (terminate).  Terminate  the  initialization   pro- 
cess and  start  executing  code. 
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Parameters:   no  parameters  are  required. 
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IV.   SYSTEM  DEBUGGING  METHODS  *MD  TOOLS 

Initially  it  appeared  that  the  debugging  of  the  compiler 
and  interpreter  would  be  straight  forward.  However,  it 
became  apparent  that  a  systematic  approach  would  have  to  be 
adopted  in  order  to  meet  the  objectives.  As  previously 
stated,  the  first  step  was  to  determine  the  degree  to  which 
the  compiler  had  been  developed.  After  accomplishing  this 
task,  the  next  step  was  to  identify  the  means  by  which 
errors  could  be  located  and  the  methods  by  which  solutions 
could  be  implemented  and  tested. 

The  method  used  to  identify  errors  within  the  compiler 
consisted  of  the  fallowing:  1.)  compiling  test  programs  and 
denoting  any  compilation  errors  and  2.)  examination  of  tte 
symbol  table  construction  and  intermediate  code  instructions 
generated  by  compiling  through  the  DATA  DIVISION  of  a  source 
program . 

A  minimum  of  forty-five  minutes  was  required  to 
recompile  either  module  —  PART  ONE  or  PART  TWO  —  of  the 
compiler  after  making  changes,  because  the  object  cede 
produced  by  the  compiler  had  to  be  linked  and  loaded.  Tris 
indicated  a  need  to  find  and  use  an  alternative  approach  for 
testing  proposed  changes.  The  approach  used,  was  *o  test 
compiler  and  interpreter  modifications  by  using  interactive 
debugging  tools  before  changing  the  compiler's  source  cole 
and  recompiling.  This  reduced  the  amount  of  time  that  would 
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otherwise  have  been  required  by  reducing  the  total  number  of 
recompilations  . 

A.   DEBUGGING  METEODOLOGY 

The  debugging  methodology  utilized,  consisted  of  steps 
similar  to  those  suggested  by  Polya's  problem-solving 
technique  [16].  First,  upon  encountering  an  occurrence  of  an 
error,  the  approach  was  to  understand  why  the  error 
occurred.  This  included  determining  what  the  compiler  or 
interpreter  had  done  right  in  its  compilation  or  execution 
of  a  source  program,  followed  by  an  analysis  of  what  the 
compiler  or  interpreter  had  done  incorrectly.  Second,  a 
theory  was  devised  to  explain  the  nature  cf  the  errcr(s), 
along  with  a  devised  method,  such  as  a  paper  and  pencil  wali 
through  using  different  variables  or  combinations  of 
variables,  to  confirm  the  theory.  Next,  the  plan  concerning 
the  error  was  implemented,  usually  this  was  accomplished  by 
a  paper  and  pencil  code  walk  through  followed  by 
recornpiiation  and  reexecution  of  the  program.  Finally,  a 
solution  was  determined,  reviewed,  and  implemented. 

It  was  observed,  as  in  other  program  debugging  efforts, 
that  a  few  errors  gave  most  of  the  difficulties  encountered 
when  debugging.  Upon  several  occasions,  it  was  thought  that 
the  origin  and  all  side  effects  of  an  error  had  been 
discovered;  later  however,  after  bavins  made  a  substantial 
coding  change,  it  was  realized  that  there  was  either  another 
boundary  condition,   circumstance   or  combinatorial  problem 
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giving  rise  to  the  error.  The  result  was  that  of  having  to 
restudy  and  refix  the  error,  which  required  additional  time 
and  effort. 

To  facilitate  the  testing  and  debugging  of  the  compiler 
and  interpreter  several  different  software  tools  were 
utilized.  It  is  difficult  to  say  which  was  the  most 
beneficial;  however,  when  they  were  used  together  the  tas* 
of  testing  and  debugging  was  significantly  enhanced. 

3.   INTERACTIVE  TCOLS 

Because  the  MICRO-COBOL  compiler  and  interpreter  were 
implemented  under  the  CP/M  operating  system,  two  C?/P 
debugging  facilities  were  used.  First,  the  Dynamic  Debugging 
Tool  [71,  DDT,  is  a  dynamic  interactive  program  whicn  allows 
testing  and  debugging  of  programs  in  the  C?/M  operation 
system  environment.  The  second  was  the  Symbolic  Instruction 
Debugger  [6],  SID,  which  expands  upon  the  features  of  DDT . 
Specifically,  SID  includes  real-time  breakpoints,  fully 
monitored  execution,  symbolic  disassembly,  assembly,  and 
memory  display  and  fill  functions.  Both  debuggers  were 
designed  to  operate  in  an  interactive  mode  and  each  had 
several  features  and  facilities  in  common  which  enhanced  the 
debugging  effort.  One  feature  which  allowed  the  setting  of 
breakpoints  at  actual  memory  locations  corresponding  to  a 
program's  source  lines  and  symbolic  names  was  used  quite 
extensively.  Another  useful  facility  was  the  ability  to 
display  and   alter   the   programs   symbolic   values,   which 
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enabled  the  substitution   of  values   to   check:  a   proposed 
solution  to  an  error. 

C.  CROSS  REFERENCE  LISTINGS 

Another  useful  facility  which  eased  the  debugging  effort 
was  the  cross  reference  listings  produced  by  the  PLM80 
compiler  used  to  compile  the  MICRO-COBOL  compiler  and 
interpreter.  There  were  three  different  listings  produced 
after  each  compilation:  1.)  a  line  numbered  source  listing, 
2.)  a  symbol  address  table,  which  included  the  name  and 
actual  memory  address  assigned  for  all  symbols  declared,  and 
3.)  a  line  address  table  which  cross  referenced  every  line 
in  the  source  listing  with  the  9060  code  generated  by  the 
PLM60  compiler  for  that  particular  line.  These  listings  were 
almost  indispensable  with  regard  to  testing  and  debugging, 
and  their  contribution  cannot  be  overemphasized. 

D.  VALIDATION  TESTS 

At  the  onset  of  this  thesis  project  it  was  very 
difficult  to  decide  how  to  test  various  constructs  and 
features  of  the  MICRO-COBOL  compiler  and  interpreter  and 
there  were  questions  regarding  test  case  design.  During 
earlier  work  [15] ,  the  HYP0-C030L  Compiler  Validation  System 
(HCCVS)  Tape  (from  the  Automated  Data  Processing  Equipment 
Selection  Office  (4DPES0))  was  acquired  —  to  be  used 
validating   the  MICRO-COBOL  compiler.  However,  the  HCCVS  was 
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never  used  and  the  tape  had  not  been  transferred  to  the 
appropriate  media.  This  transfer  was  accomplished  later 
[12].  3y  using  the  HCCVS  as  the  evaluation  package,  the 
auestions  regarding  test  case  construction  and  design  were 
resolved  and  testing  proceeded.  The  HCCVS  was  used  primarily 
as  a  test  "bed  for  PART  ONE  of  the  compiler,  having  as  an 
objective  the  goal  of  ensuring  the  proper  construction  of 
the  symbol  table  and  data  initialization.  Because  some  of 
the  FYP0-C030L  constructs  were  not  implemented  in  the 
MICRO-COBOL  compiler  (see  Appendix  E)  ,  the  compilation  of 
any  HCCVS  program  past  the  PROCEDURE  DIVISION  statement  was 
not  successful. 
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V.   CONCLUSIONS  AND  RECOMMENDATIONS 

A  significant  portion  of  the  MICRO-COBOL 
Compiler/Interpreter  has  been  tested,  debugged  and 
documented.  The  following  specific  language  features  and 
facilities  previously  not  implemented,  or  implemented 
incorrectly,  have  been  successfully  implemented,  tested  and 
debugged  during  this  project:  1.)  the  compiler's  ability  to 
handle  any  sequence  of  MICRO-COBOL  language  constructs 
(PICTURE  CLAUSE,  VALUE  CLAUSE,  OCCURS  CLAUSE,  and  USAGE  COMP 
CLAUSE)  in  the  declaration  of  an  identifier,  2.)  record 
identifier  declarations  with  up  to  ten  levels  of  elementary 
field  items,  3.)  record  and  elementary  field  identifier 
redefinitions,  4.)  nested  redefinitions,  and  5.)  error 
message  generation  for  duplicate  identifier  declarations 
within  the  DATA  DIVISION. 

Testing  and  debugging  has  been  accomplished  for  all 
presently  implemented  MICRO-COBOL  language  constructs 
occurring  in  the  DATA  DIVISION  of  a  source  program. 
Specifically,  testing  was  performed  by  compiling  through  the 
DATA  DIVISION  of  the  first  ten  HCCVS  test  programs. 

In  addition,  the  MICRO-COBOL  compiler  has  been 
completely  documented.  This  documentation  includes  the 
following:  1.)  module  organization,  2.)  module  interfaces, 
3.)  memory  organization  of  the  Interpreter,  4.)  construction 
and   data   initialization   of   the  symbol  table,  and  5.)  key 
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internal  data  structures. 

Several  areas  remain  which  could  be  improved,  developed 
and  implemented,  to  enhance  the  MICRC-CC30L 
Compiler/Interpreter  system,  these  include:  1.)  correction 
of  the  numerical  algorithms  in  the  interpreter  to  allow  for 
signed-f ractional  arithmetic,  2.)  implementation  of  numeric 
editing  capabilities,  3.)  implementation  of  a  printer 
control  feature  and  interface,  and  4.)  testing  and  debugging 
of  the  compiler's  ability  to  compile  the  PROCEDURE  DIVISION 
of  the  HCCVS  test  programs. 
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I.   ORGANIZATION 

The  compiler  is  designed  to  run  on  an  8082  system  in  an 
interactive  mode  through  the  use  of  a  teletype  or  console. 
It  requires  at  least  24K  of  main  memory  and  a  mass  stora?e 
device  for  reading  and  writing.  The  compiler  is  composed  of 
two  parts  ,  each  of  which  reads  a  portion  of  the  input  file. 
Part  One  reads  the  input  program  to  the  end.  of  the  Data 
Division  and  builds  the  symbol  table.  At  the  end  of  the  Data 
Division,  Part  One  is  overlayed  hy  Part  Two  which  uses  the 
symbol  table  to  produce  the  code.  The  output  code  is  written 
as  it  is  produced  to  minimize  the  use  of  internal  storage. 

The  BUILD  Program  builds  the  core  image  for  the 
intermediate  code  and  performs  such  functions  as 
backs tuffing  addresses.  BUILD  then  loads  the  INTERPRETER 
addresses.  BUILD  then  transfers  control  to  the  INTRDR 
routine.  The  INTRDR  routine  copies  the  interpreter  into 
memory  and  transfers  control  to  the  Interpreter.  The 
interpreter  is  controlled  by  a  large  case  statement  that 
decodes  the  instructions  and  performs  the  required  actions. 

As  a  tool  for  debugging  the  compiler  the  DECODE  Program 
was  created;  it  reads  the  intermediate  code  file  and 
translates  the  instructions  into  mnemonics  followed  by 
parameters . 
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II.   MICRO-COBOL  ELEMENTS 

This  section  contains  a  description  of  each  element  in 
the  language  and  shows  simple  examples  of  their  use.  The 
following  conventions  are  used  in  explaining  the  formats: 
Elements  enclosed  in  broken  "braces  <  >  are  themselves 
complete  entities  and  are  described  elsewhere  in  the  manual. 
Elements  enclosed  in  braces  {  }  are  choices,  one  of  the 
elements  which  is  to  be  used.  Elements  enclosed  in  brackets 
[  ]  are  optional.  All  elements  in  capital  letters  are 
reserved  words  and  must  be  spelled  exactly. 

User  names  are  indicated  in  lower  case.  These  names  have 
been  restricted  to  12  characters  in  length.  There  is  only 
one  restriction  on  user  names,  the  first  character  must  be 
an  alpha  character.  The  remainder  of  the  user  name  can  have 
any  combination  of  represen table  character  in  it. 

The  input  to  the  compiler  does  not  need  to  conform  to 
standard  COBOL  format.  Tree  form  input  will  be  accepted  as 
the  default  condition.  If  desired,  sequence  numbers  can  be 
entered  in  the  first  six  positions  of  each  line.  However,  a 
toggle  needs  to  be  set  to  cause  the  compiler  to  ignore  the 
seauence  numbers. 
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IDENTIFICATION  DIVISION 
ELEMENT: 

IDENTIFICATION  DIVISION  Format 
FORMAT: 

IDENTIFICATION  DIVISION. 

PROGRAM-ID.    <comment>. 

[AUTHOR.    <comment>.] 

[DATE-WRITTEN.    <comment>  .1 

[SECURITY.    <comment>.] 

DESCRIPTION: 

This  division  provides  information  for  program  iden- 
tification for  the  reader.  The  order  of  the  lines  is 
fixed . 

EXAMPLES: 

IDENTIFICATION    DIVISION. 

PROGRAM-ID.    SAMPLE. 

AUTHOR.    MICHAEL-L-RICE. 
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ENVIRONMENT  DIVISION 


ELEMENT: 


ENVIRONMENT  DIVISION  Format 


FORMAT: 


ENVIRONMENT  DIVISION 


CONFIGURATION  SECTION. 


SOURCE-COMPUTER.    <comment>    [DEBUGGING  MODE] 


OBJECT-COMPUTER.  <comment> 


[INPUT-OUTPUT    SECTION. 

FILE-CONTROL. 

<f ile-control-entry>  .  .  . 

[I-O-CONTROL. 

SAME   file-name-1    file-name-2    [f ile-name-3] 

ffile-name-4]    [f ile-name-5]  .      ]      ] 

DESCRIPTION: 

This  division  determines  the  external  nature  of  a 
file.  In  the  case  of  CP/M  all  of  the  files  used  can 
he  accessed  either  sequentially  or  randomly  except  for 
variahle  length  files  which  are  sequential  only.  The 
debugging  mode  is  also  set  by  this  section. 
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< file-con  trol-entry> 


ELEMENT: 


<f ile-control-entry> 


FORMAT: 


1. 


SELECT   file-name 


ASSIGN    imolementor-name 


[ORGANIZATION  SEQUENTIAL] 


[ACCESS  SEQUENTIAL] . 


2. 

SELECT    file-name 

ASSIGN   implementor-name 

ORGANIZATION    RELATIVE 

[ACCESS    {SEQUENTIAL    [RELATIVE   data-name! }] . 

{RANDOM  RELATIVE  data-name       } 

DESCRIPTION: 

The  file-control-entry  defines  the  type  of  file  that 
the  program  expects  to  see.  There  is  no  difference  on 
the  diskette,  hut  the  type  of  reads  and  writes  that 
are   performed   will  differ.   For  CP/M  the  implementor 
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name  needs  to  conform  to  the  normal  specifications 
EXAMPLES: 

SELECT  CARDS 

ASSIGN  CARD.?IL. 

SELECT  RANDOM-EILE 

ASSIGN  A. RAN 

ORGANIZATION  RELATIVE 

ACCESS  RANDOM  RELATIVE  RAND-JLAG. 
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DATA    DIVISION 
ELEMENT: 

DATA   DIVISION      Format 
FORMAT: 

DATA  DIVISION. 
[FILE  SECTION. 
[FD   file-name 

[BLOCK   integer-1    RECORDS] 
[RECORD    [integer-2   TO]    integer-3] 
[LABEL  RECORDS    {STANDARD}] 

{OMITTED    } 
[VALUE   OF   implementor-name-1    literal-1 

[inplementor-name-2   literal-2]    ...   ]. 
[<record-description-entry>]    ...]    ... 
[WORKING-STORAGE    SECTION. 
[<record-description-entry>]     ...    ] 
[LINKAGE    SECTION. 
[<record-descript ion-entry>]     ...    ] 
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DESCRIPTION: 

This  is  the  section  that  describes  how  the  data  is 
structured.  There  are  no  major  differences  from  stan- 
dard COBOL  except  for  the  following:  1.  Label 
records  make  no  sense  on  the  diskette  so  no  entry  is 
required.  2.  The  VALUE  OF  clause  likewise  has  no 
meaning  for  CP/M.  3.  The  linkage  section  has  not  been 
implemented . 

If  a  record  is  given  two  lengths  as  in  RECORD  12  TO 
123,  the  file  is  taken  to  be  variable  length  and  can 
only  be  accessed  in  the  sequential  mode.  See  the  sec- 
tion on  files  for  more  information. 
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<ccmment  > 
ELEMENT: 

<comment> 
FORMAT: 

any  string  of  characters 

DESCRIPTION: 

A  comment  is  a  string  of  characters.  It  ma;/  include 
anything  other  than  a  period  followed  by  a  blank  or  a 
reserved  word,  either  of  which  terminate  the  string. 
Comments  may  "be  empty  if  desired,  but  the  terminator 
is  still  required  by  the  program. 

EXAMPLES: 

this  is  a  comment 

an otheronea 11 run together 

S080b  161 
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<data-descripti  on-ent ry  > 

ELEMENT: 

<data-description-entry>  Format 

FORMAT: 

level-number  {data-name} 

{FILLER    } 

[REDEFINES    data-name! 

[PIC    character-string] 

[USAGE    {COMP        }1 

{DISPLAY} 

[SIGN  {LEADING}  [SEPARATE! 1 

{TRAILING} 

[OCCURS  integer] 

[SYNC  [LEFT  ]] 

[RIGHT] 

[VALUE  literal]  . 

DESCRIPTION: 

This  statement  describes  the  specific  attributes   of 
the  data.   Since  the  808?  is  a  byte  machine,  there  was 
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no  meaning  to  the  SYNC  clause,  and   thus   it  has   not 
been  implemented. 
EXAMPLES : 

01  CARD-RECORD. 

02  PART  PIC  X(5) . 

02  NEXT-PART  PIC  99V99  USAGE  COMP. 

02  FILLER. 

03  NUMB  PIC  S9(3)V9  SIGN  LEADING  SEPARATE. 

03  LONG-NUME  9(15). 

03  STRING  REDEEINES  LONG-NUMB  PIC  X(15). 
02  ARRAY  PIC  99  OCCURS  100. 
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PROCEDURE  DIVISION 
ELEMENT: 

PROCEDURE  DIVISION  Format 
FORMAT: 
1. 

PROCEDURE  DIVISION  [USING  namel  [name2]  ...  [names] 1  . 

section-name  SECTION. 

[paragraph-name.  <sentence>  [<sentence>  ...  1  ...  ]  .. 


PROCEDURE  DIVISION  [USING  namel  [name2]  ...  [name5] ] . 

paragraph-name.  <sentence>  [<sentence>  ...1  ... 

DESCRIPTION: 

As  is  indicated,  if  the  program   is   to   contain  sec- 
tions,  then  the  first  paragraph  must  be  in  a  section 
The  USING  option  is  part  of  the  interprogram   commur.i 
cation  module  and  has  not  been  implemented. 
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<sentence> 

ELEMENT: 

<sentence> 
FORMAT: 

<imperat  ive-statement> 

<conditional-statement> 

ENTER   verb 

DESCRIPTION: 

All  sentences  other  than  ENTER  fall  in  one  of  the  two 
main  catigories.  ENTER  is  part  of  the  interprogran 
communication  module. 
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<imperative-statement> 

ELEMENT: 

<imperat  ive-statement> 
EORMAT: 

The  following  verbs  are  always  imperatives: 

ACCEPT 

CALL 

CLOSE 

DISPLAY 

EXIT 

go 

MOVE 

OPEN 

PERFORM 

STOP 

The  following  may  he  imperatives: 

arithmetic  verbs  without  the  SIZE  ERftCH  statement 

and  DELETE,  WRITE,  and  REWRITE  without  the  INVALID  option 
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<condit  ional-statements> 
ELEMENT: 

<condltional-s tatements> 
FORMAT: 

IF 

READ 

arithmetic  verts  with  the  SIZE  ERROR  statement 

and  DELETE,  WRITE,  and  REWRITE  with  the  INVALID  option 
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ELEMENT: 


ACCEPT 
FORMAT: 

ACCEPT  <identifier> 

DESCRIPTION: 

This  statement  reads  up  to  255  characters  from  the 
console.   The  usage  of  the  item  nust  be  DISPLAY. 

EXAMPLES: 

ACCEPT  IMMAGE 


ACCEPT  NUM(9) 
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ADD 

ELEMENT: 

ADD 
FORMAT: 

ADD   {identifier}    [{identif ier-1}]    TO    identifier-2 
{literal        }      {literal  } 

[ROUNDED]     [SIZE   EFROP.  <  imperat  ive-s  tatenen  t  >1 

DESCRIPTION: 

This  instruction  adds  either  one  or  two  numbers  to  a 
third  with  the  result  being  place!  in  the  last  loca- 
tion. 

EXAMPLES: 

ADD   10    TC    NUMB1 

ADD   X    Y    TO    Z    ROUNDED. 

ADD    100    TC    NUMBER    SIZE    ?RR0R    GO    ERROR-LCC 
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CALL 


ELEMENT: 

CALL 
FORMAT: 

CALL  literal  [USING  namel  [name2]  ...  [name5]] 

DESCRIPTION: 

CALL  is  not  implemented . 
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CLOSE 
ELEMENT: 

CLOSE 
ECRMAT: 

CLOSE  file-name 

DESCRIPTION: 

Files  must  be  closed  if  they  have  been  written.  How- 
ever, the  normal  requirement  to  close  an  input  file 
prior  to  the  end  of  processing  does  net  exist. 

EXAMPLES: 

CLOSE  EILE1 

CLOSE  EANDEILE 
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DELETE 
ELEMENT: 

DELETE 
FORMAT: 

DELETE   file-name    [INYALir   <imperative-statement>] 

DESCRIPTION: 

This  statement  requires  the  file-name  of  the  item 
to  he  deleted.   The  record  is  logically  removed  hy 
filling  it  with  a  high  value  character,  which  is  not 
displayabie  to  the  console  or  line  printer.   The  log- 
ical record  space  can  he  used  again  by  writing  a 
valid  record  in  its  place. 

EXAMPLES : 

DELETE  FILE-NAME 
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DISPLAY 
ELEMENT: 

DISPLAY 
FORMAT: 

DISPLAY  {identifier}  [{identi f ier-1}] 
{literal   }   {literal     } 

DESCRIPTION: 

This  displays   the   contents   of  an   identifier   or 
displays   a   literal   on   the   console.   Usage  must  be 
DISPLAY.  The  maximum  length  of  the  display  is  80  char- 
acters for  literal  values  and  255  characters  for 
identifiers.  Only  two  identifiers/literals  are 
allowed  for  each  DISPLAY  command. 

EXAMPLES: 

DISPLAY  MESSAGE-1 

DISPLAY  MESSAGE-3  10 

DISPLAY  'THIS  MUST  BE  THE  END' 
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nvirz 


ELEMENT: 

DIVIDE 


FORMAT: 


DIVIDE  {identifier}  INTO  identif ier-1  [ROUNDED] 


{literal   } 


[SIZE   ERROR   <imperative-statement>] 


DESCRIPTION: 

The  result  of  the  division  is  stored  in 

any  remainder  is  lost. 
EXAMPLES: 

DIVIDE  NUMB  INTO  STORE 

DIVIDE  25  INTO  RESULT 


lientif ier-1 ; 
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0  M  If  V  t 


ELEMENT: 

ENTER 
FORMAT: 

ENTER    language-name    [routine-name] 

DESCRIPTION: 

This  construct  is  not  implimented. 
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IX  IT 
ELEMENT: 

EXIT 
FORMAT: 

EXIT  [PROGRAM] 

DESCRIPTION: 

The  EXIT  command  causes  no  action  by  the  interpreter 
but  allows  for  an  empty  paragraph  for  the  construction 
of  a  common  return  point.  The  optional  PROGRAM  state- 
ment is  not  implemented  as  it  is  part  of  the  mterpro- 
gram  communication  module. 

EXAMPLES: 

RETURN. 

EXIT. 
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50 

ELEMENT: 
GO 

FORMAT: 
1. 

GO    procedure-name 
2. 

GO   procedure-1    [procedure-2]     ...    procedure-20 
DEPENDING   identifier 

DESCRIPTION: 

The  GO  command  causes  an  unconditional  cranch  to  the 
routine  specified.  The  second  form  causes  a  forward 
"branch  depending  on  the  value  of  the  contents  of  the 
identifier.  The  identifier  must  be  a  numeric  integer 
value.   There  can  he  no  more  than  2P   procedure  names. 

EXAMPLES : 

GO  R5AD-CJRD. 

GO  RSAB1  READ2  READ3  DEPENDING  READ-INDEX. 
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IF 
ELEMENT: 
IE 
EO  F.MAT: 

IF  <condition>  {imperative    }  ELSE  imperative-2 

{NEXT  SENTENCE} 

DESCRIPTION: 

This  is  the  standard  COBOL  IF   statement.    Note   that 

there  is  no  nesting  of  I?  statements  allowed  since  the 

IF  statement  is  a  conditional. 
EXAMPLES: 

IF    A    G-REATEP    3    ADD    A    TO    C    ELSE    GO    ERROR-ONE. 

IF  A  NOT  NUMERIC  NEXT  SENTENCE  ELSE  MOVE  ZERO  TO  A. 
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MOVE 

ELEMENT: 

MOVE 
FORMAT: 

MOVE  {identifier-1}  TO  identifier- 2 
{literal     } 

DESCRIPTION: 

The  standard  list  of  allowable  moves  applies  to  this 
action.  As  a  space  saving  feature  of  this  implementa- 
tion, all  numeric  moves  go  through  the  accumulators. 
This  makes  numeric  moves  slower  than  alpha-numeric 
moves,  and  where  possible  they  should  be  avoided.  Any 
move  that  involves  picture  clauses  that  are  exactly 
the  same  can  be  accomplished  as  an  alpha-numeric  move 
if  the  elements  are  redefined  as  alpha-numeric;  also 
all  group  moves  are  alpha-numeric. 

EXAMPLES: 

MOVE  SPACE  TO  PRINT-LINE. 

MOVE  A (10)  TO  B(PT?.)  . 
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MULTIPLY 

ELEMENT: 

MULTIPLY 
FORMAT: 

MULTIPLY  {identifier}  BY  identif ier-2  [ROUNDEL] 
{literal    } 
[SIZE  ERROR  <imperative-statement  >] 

DESCRIPTION: 

The  multiply  routine  requires  enougn  space  to  calcu- 
late the  result  with  the  full  number  of  decimal  digits 
prior  to  moving  the  result  into  iden tifier-2.  This 
means  that  a  number  with  5  places  after  the  decimal 
multiplied  by  a  number  with  6  places  after  the  decimal 
will  generate  a  number  with  11  decimal  places  which 
would  overflow  if  there  were  -nore  than  ?  digits  before 
the  decimal  place. 

EXAMPLES : 

MULTIPLY  X  BY  Y. 

MULTIPLY  i  BY  3(7)  SIZE  ERROR  GO  OVERFLOW. 


116 


OPS  . 

ELEMENT: 

OPEN 
FORMAT: 

OPEN  {INPUT  file-name  } 
{OUTPUT  file-name} 
{1-0  file-name   } 

DESCRIPTION: 

The  three  types  of  OPENS  have  exactly  the  same  effect 
on  the  diskette.  However,  they  do  allow  for  internal 
checking  of  the  other  file  actions.  For  example,  a 
write  to  a  file  set  open  as  input  will  cause  a  fatal 
error . 

EXAMPLES : 

OPEN  INPUT  CARDS. 

OPEN    OUTPUT   REPORT-EILE. 
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PERFORM 

ELEMENT: 

PERFORM 
FORMAT: 
1. 

PERFORM  procedure-name  [THRU  procedure-name-2l 


PERFORM  procedure-name  [THRU  procedure-r.ame-2] 
{identifier}  TIMES 
{integer   } 
3. 

PERFORM  procedure-name  [THRU  procedure-name-2] 
UNTIL  <condition> 

DESCRIPTION: 

All  three  options  are  supported.  Branching  may  be  ei- 
ther forward  or  backward,  and  the  procedures  called 
may  have  perform  statements  in  them  as  Ion.?  as  the  end 
points  do  not  coincide  or  overlap. 

EXAMPLES: 

PERFORM    CPSN-RCUTINE. 
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PERFORM    TOTALS    THRU    END-REPORT. 


PERFORM  SUM  10  TIMES. 


PERFORM  SKIP-LINE  UNTIL  PG-CNT  GREATER  60 
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READ 


ELEMENT: 

P.EAD 
FORMAT: 
1. 


READ  file-name  INVALID  <imperat i ve-s ta tement> 


2. 


READ  file-name  END  ^imperative-statement> 

DESCRIPTION: 

The  invalid  condition  is  only  applicable  to  files  in  a 

random  mode.   All   sequential  files  must  have  an  END 

statement . 
EXAMPLES : 

READ  CARDS  END  GO  END-OF-FILE. 

READ  RANDOM-FILE  INVALID  MOVE  SPACES  TO  REC-1. 
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REWRITE 

ELEMENT: 

REWPITE 
FORMAT: 

REWRITE  record-name  [INVALID  <impera ti ve>] 

DESCRIPTION: 

REWRITE  is  only  valid  for  files  that  are  open  in  the 
1-0  mode.  The  INVALID  clause  is  only  valid  for  random 
files.  This  statement  results  in  the  current  record 
"being  written  hack:  into  the  place  that  it  was  just 
read  from,  the  last  executed  read. 

EXAMPLES: 

REWRITE  CARDS. 

REWRITE  RAND-1  INVALID  PERFORM  ERROR-CHECK. 
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STOP 
ELEMENT: 

STOP 
FORMAT: 

STOP  {RUN    } 
{literal} 

DESCRIPTION: 

This  statement  ends  the  running   of   the   interpreter. 

If  a   literal   is   specified,   then   the   literal   is 

displayed  on  the  console  prior  to  termination   of   the 

pr  os  ra  m . 
EXAMPLES: 

STOP  RUN . 

STOP  1. 

STOP  "INVALID  FINISH". 
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SUBTRACT 
ELEMENT: 

SUBTRACT 
FORMAT: 

SUBTRACT    {identifier-1}    [identif ier-2]    FROM   identif ier-3 
{literal-1        }    [literal-2        ] 
[ROUNDED!     [SIZE   ERROR  <imperati ve-s ta tement>] 

DESCRIPTION: 

Identif ier-3  is  decremented  by  the  value  of 
identifier/literal  one,  and ,  if  specified, 
identifier/literal  two.  The  results  are  stored  back 
in  identif ier-3.  Rounding  and  size  error  options  are 
available  if  desired. 

EXAMPLES: 

SU3TRACT  10  FROM  5U3(12). 

SUBTRACT  A  B  FROM  C  ROUNDED. 
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WRITE 
ELEMENT: 

WRITE 
FORMAT: 
1. 

WRITE    record-name    [{BEFORE}    ADVANCING    (INTESS?.}] 

{AFTER    }  (PAGE         } 

2. 

WRITE    record-name    INVALIE   <imperative-statement > 

DESCRIPTION': 

The  record  specified  is  written  to  the  file 
specified  in  the  file  section  of  the  source 
program.  The  INVALID  option  only  applies  to 
random  files. 

EXAMPLES: 

WRITE  OUT-FILE. 

WRITE  MND-FILE  INVALID  PERFORM  ERROR-REC07. 
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<condit ion> 
ELEMENT: 

<condition> 
FORMAT: 

RELATIONAL  CONDITION  : 

{identifier-1}  [NOT]  {GREATER}  { iden ti f ier-2} 
{literal-1}  {LESS    }  {literal-2    } 

{EQUAL   } 
CLASS  CONDITION: 

identifier  [NOT]  {NUMERIC    } 

(ALPHABETIC) 

DESCRIPTION: 

It  is  not  valid  to  compare  two  literals.  The  class 
condition  NUMERIC  will  allow  for  a  si^n  if  the  iden- 
tifier is  signed  numeric. 

EXAMPLES: 

A  NOT  LESS  10. 

LINE  GREATER  'c". 

NUMB1  NOT  NUMERIC 
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Subscripting 

ELEMENT: 

Subscripting 
FORMAT: 

data-name  (subscript) 

DESCRIPTION: 

Any  item  defined  with  an  OCCURS  may  be  referenced  by 
a  subscript.  The  subscript  may  be  a  literal  integer, 
or  it  may  be  a  data  item  that  has  been  specified  as  an 
integer.  If  the  subscript  is  signed,  the  sign  must  be 
positive  at  the  time  cf  its  use. 

EXAMPLES : 

A(10) 

ITSM(SUB) 
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III.   COMPILER  TOGGLES 

There  are  four  compiler  toggles  which  are  controlled  by 
an  entry  following  the  compiler  activation  command,  C030L 
<filename>.  The  format  of  the  entry  consists  of  following 
<filename>  by  one  space  and  then  entering  a  "$"  followed 
immediately  by  the  desired  toggles.  There  must  be  only  one 
space  after  <filename>  and  no  spaces  between  the  "$"  and  the 
toggles.  The  following  is  an  example  of  a  typical  entry: 

COBOL  EXAMPLE  $ST 
This   entry   would  cause  the  compiler  to  ignore  the  sequence 
numbers  entered  at  the  beginning  of  each  input  file  line  and 
print  the  token  numbers  to  the  output  device.  In   each   case 
the  toggle  reverses  the  default  value. 

$L  —  list  the  input  code  on  the  screen  as  the  program 
is  compiled.  Default  is  on.  Error  messages  will  be  difficult 
to  understand  if  this  toggle  is  turned  off,  but  if  the 
interface  device  is  a  teletype,  it  may  be  desired  in  certain 
situations. 

$S  —  sequence  numbers  are  in  the  first  six  positions  of 
each  record.  Default  is  off. 

$P  —  list  productions  as  they  occur.  Default  is  off. 

$T  —  list  tokens  from  the  scanner.  Default  is  off. 
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IV.   RUN  TIME  CONVENTIONS 

This  section  explains  how  to  run  the  compiler  on  tne 
current  system.  The  compiler  expects  to  see  a  file  with  a 
type  of  CBL  as  the  input  file.  In  general,  the  input  is  free 
form.  If  the  input  includes  sequence  numbers  then  the 
compiler  must  be  notified  by  setting  the  appropriate  toggle. 
The  compiler  is  started  by  typing  COBOL  <file-name>.  Vhere 
the  file  name  is  the  system  name  of  the  input  file.  There  is 
no  interaction  required  to  start  the  second  part  of  the 
compiler.  The  output  file  will  have  the  same  <file-name>  as 
the  input  file,  and  will  be  given  a  file  type  of  CIN.  Any 
previous  copies  of  the  file  will  be  erased. 

The  interpreter  is  started  by  typing  EXEC  <filename>. 
The  first  program  is  a  loader,  and  it  will  display  "LOAD 
FINISHED'  to  indicate  successful  completion.  The  run-time 
package  will  be  brought  in  by  the  IMTRDR  routine,  and 
execution  should  continue  without  interuption. 
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V.   FILE  INTERACTIONS  WITH  CP/M 

The  file  structure  that  is  expected  by  the  program 
imposes  some  restrictions  on  the  system.  References  4  and  5 
contain  detailed  information  on  the  facilities  of  CP/M,  and 
should  he  consulted  for  details.  The  information  that  has 
been  included  in  this  section  is  intended  to  explain  where 
limitations  exist  and  how  the  program  interacts  with  the 
system. 

All  files  in  CP/M  are  on  a  random  access  device,  and 
there  is  no  way  for  the  system  to  distinguish  sequential 
files  from  files  created  in  a  random  mode.  This  means  that 
the  various  types  of  reads  and  writes  are  all  valid  to  any 
file  that  has  fixed  length  records.  The  restrictions  of  the 
ASSIGN  statement  do  prevent  a  file  from  being  open  for  both 
random  and  sequential  actions  during  one  program. 

Each  logical  record  is  terminated  by  a  carriage  return 
and  a  line  feed.  In  the  case  of  variable  length  records, 
this  is  the  only  end  mark  that  exists.  This  convention  was 
adopted  to  allow  the  various  programs  which  are  used  in  CP/M 
to  worlr  with  the  files.  Files  created  by  the  editor,  for 
example,  will  generally  be  variable  length  files.  This 
convention  does  remove  the  capability  of  reading  variable 
length  files  in  a  random  mode. 

All  of  the  physical  records  are  123  bytes  in  length,  and 
the  program  supplies  buffer  space  for  these  records  in 
addition   to   the  logical  records.  Logical  records  may  be  of 
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any  desired  length. 
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VI.   EPROR  MESSAGES 


A.   COMPILER  FATAL  MESSAGES 


ER    Bad  read  —  disk  error,  no  corrective   action   can   be 

taken  in  the  program. 
CL    Close  error  —  unable  to  close  the  output  file. 
MA     Make  error  —  could  not  create  the  output  file. 
MO    Memory  overflow  —  the  code   and   constants   generated 

will  not  fit  in  the  alloted  memory  space. 
OP    Open  error  —  can  not  o^en  the  input  file,  or  no   such 

file  present. 
SO     Stack  overflow  —  the  LALH(l)  parsing  stack  has  exceeded 

its  maximum  allowable  size. 
ST    Symbol  table  overflow  —  symbol  table  is  toe  large  for 

the  allocated  space. 
WH    Write  error  —  disk  error,   could   not   write   a   code 

record  to  the  disk. 


3.   COMPILER  WARMINGS 


CI    Close  error  —  attempted  to  close  a  non-existing  file 
DC     Decimal  count  error  —  decimal  significance  is  create 

than  18  digits. 
DI     Duplicate  identifier  —  the  identifier  name  has  been 
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previously  declared  in  the  WORKING  STORAGE  area  of  the 

program . 
EF    Excess  files  —  the  number  of  files  declared  in  the 

source  program  exceeds  24. 
EL    Extra  levels  —  only  10  levels  are  allowed. 
FT    File  type  —  the  data  element  used  in  a  read  or  write 

statement  is  not  a  file  name. 
IA    Invalid  access  —  the  specified  options  are  not  an 

allowable  combination. 
ID    Identifier  stack  overflow  —  more  than  20  items   in   a 

GO  TO  —  DEPENDING  statement. 
IS    Invalid  subscript  —  an  item  was   subscripted   but   it 

was  not  defined  by  an  OCCURS. 
IT    Invalid  type  —  the  field  types  do  not  match  for   this 

statement . 
LE    Literal  error  —  a  literal  value  was   assigned   to   an 

item   that  is  part  of  a  group  item  previously  assigned 

a  value. 

LV    Literal  value  error  —  the  PICTURE  clause  field  type 

does  not  match  the  VALUE  clause  literal  type. 
MD    Multiple  decimals  —  a  numeric  literal  in  a  VALUE 

clause  contains  more  than  one  decimal  point. 
MS    Multiple  signs  —  a  signed  numeric  literal  in  a  VALUE 

clause  contains  more  than  one  sign. 
NF    No  file  assigned  —  there  was   no   SELECT   clause   for 

this  file. 
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NI    Not  implemented  —  a  production  was  used  that   is   not 

implemented . 
NN    Non-numeric  —  an  invalid  character  was   found   in  a 

numeric  string. 
NP    No  production  —  no  production  exists  for  the  cuurrent 

parser  configuration?  error  recovery  will  automatically 

occur. 
NV    Numeric  value  —  a  numeric  value  was  assigned   to   a 

non-numeric  item. 
OE    Open  error  —  attempt  to  open  a  file  that  was  not  de- 
clared? or  attempted  to  open  a  file  for  1-0  that  was 

not  a  RELATIVE  file. 
PC    Picture  clause  —  an  invalid  character  or  set  of 

characters  exists  in  the  picture  clause. 
PE    Paragraph  first  —  a  section  header  was  produced  after 

a  paragraph  header,  which  is  not  in  a  section. 
Rl    Redefine  nesting  —  a  redefinition  was  made   for  an 

item  which  is  part  of  a  redefined  item. 
R2    Hedefine  length  —  the  length  of  the  redefinition  item 

was  greater  than  the  item  that  it  redefined.  This  error 

message  may  he  printed  out  one  identifier  past  the 

redefining  identifier  record  in  which  it  occurred. 
R3    Redefines  misplaced  —  a  redefines  was  attempted  in  the 

FILE  SECTION  of  the  source  program. 
SE    Scanner  error  —  the  scanner  was   unable   to   read   an 

identifier  due  to  an  invalid  character. 
SG-    Sign  error  —  either  a  sign  was   expected  and   not 
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found,  or  a  si^n  was  present  when  not  valid. 
SL    Significance  loss  —  the  number  assigned  as  a  value  is 

larger  than  the  field  defined. 
TE    Type  error  —  the  type  of  a  subscript  index  is  not 

integer  numeric. 
UI    Undeclared  identifier  —  the  identifier  was  not 

declared  in  WORKING  STORAGE  area  of  the  source  program 
VE    Value  error  —  a  value  statement  was  assigned  to  an 

item  in  the  file  section. 
WI    Wrong  level  error  —  program  attempted  to  write  a 

record  other  than  an  01  level  record  to  an  output 

file. 


C.   INTERPRETER  FATAL  ERRORS 


CL    Close  error  —  the  system  was  unable  to  close  an  output 
file. 

ME    Make  error  —  the  system  was  unable  to  make   an  input 
file  on  the  disk. 

ME    No  file  —  an  input  file  could  not  be  opened. 

Wl    Write  non-sequential  —  attempted  to  WRITE  to  a  file 
opened  for  INPUT  or  a  file  opened  for  1-0  when  ACCESS 
was  SEQUENTIAL. 

W2    Wrong  key  —  attempted  to  change  the  key  value  to  a 
lower  value  than  the  number  of  the  last  record  writ- 
ten. 
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W3    Write  input  —  attempted  to  WRITE  to  a  file  opened 
for  INPUT. 

W4    Write  non-empty  —  attempted  to  WRITE  to  a  non-empty 
record . 

W5    Read  output  —  attempted  to  READ  a  file  opened  for 
OUTPUT. 

W6    Rewrite  error  —  attempted  to  REWRITE  to  a  file 
not  opened  fo  I-O. 

W7    Rewrite  error  —  attempted  to  REWRITE  a  record  before 
reading  the  file;  or  multiple  REWRITE  attempts  with- 
out doinsr  a  READ  between  each. 


V  . 


INTERPRETER  WARNING  MESSAGES 


EM    End  marie  —  a  record  that  was  read  did  not  have  a 

carriage  return  or  a  line  feed  in  the  expected  location. 

GD    Go  to  depending  —  the  value  of  the  depending  indicator 
was   greater   than  the  number  of  available  branch 
addresse  s . 

IC     Invalid  character  —  an  invalid  character   was   loaded 

into  an  output  field  during  an  edited  move.   Eor  example, 
a   numeric   character   into   an   alphabetic-only 
field. 

SI     Sign  Invalid  —  the  sign   is  not  a  "+"  or  a  "-'. 

WE     Write  Error  —  attempted  to  write  to  an  output  file. 
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APPENDIX  3 
LIST  OF  MICRO-COBOL  RESERVED  WORDS 

The  following  is  a  list  of  reserved  words  for 
MICRO-COBOL.  The  reserved  words  are  the  same  as  those 
specified  for  the  HYPO-COBOL  language,  except  where  noted 
with  an  asterisk  (*) . 


ACCEPT 
ACCESS 
ADD 
ADVANCING 

AFTER 

ALPHABETIC 

ASSIG-N 

AUTHOR 

BEFORE 

BLOCK 

BY 

CALL 

CLOSE 

COBOL 

COMP 

CONFIGURATION 

DATA 

DATE-WRITTEN 

DE3UGGING 

DELETE 

DEPENDING 

DISPLAY 

DIVIDE 

DIVISION 

ELSE 

END 

ENTER 


ENVIRONMENT 

EOF  * 

ECUAL 

ERROR 

EXIT 

FD 

FILE 

FILE-CONTROL 

FILLER 

FROM 

GO 

GREATER 

I-C 

1-0 -CONTROL 

IDENTIFICATION 

IF 

INPUT 

INPUT-OUTPUT 

INVALID 

INTO 

LABEL 

LEADING 

LEFT 

LESS 

LINKAGE 

MODE 

MOVE 


MULTIPLY 

NEXT 

NOT 

NUMERIC 

OBJECT-COMPUTER 

OCCURS 

OF 

OMITTED 

OPEN 

ORGANIZATION 

OUTPUT 

PAGE 

PERFORM 

PIC 

PROCEDURE 

PROGRAM 

PROGRAM-ID 

QUOTE 

RANDOM 

READ 

RECORD 

RECORDS 

REDEFINES 

RELATIVE 

REWRITE 

RIGHT 

ROUNDED 


RUN 

SAME 

SECTION 

SECURITY 

SELECT 

SENTENCE 

SEPARATE 

SEQUENTIAL 

SIGN 

SIZE 

SOURCE-COMPUTER 

SPACE 

STANDARD 

STOP 

SUBTRACT 

SYNC 

THRU 

TIMES 

TO 

TRAILING 

UNTIL 

USAGE 

USING 

VALUE 

WORKING-STORAGE 

WHITE 
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APPENDIX  C 

The  MICRO-COEOL  compiler  and  interpreter  source  files 
currently  exist  in  the  high  level  language  PLM80  and  are 
edited  and  compiled  under  the  ISIS  ooerating  system  on  a 
INTEL  Corporation  MDS  system.  This  is  a  description  of  the 
procedures  required  to  compile  and  establish  the  programs  to 
compile  and  interpret  a  MICRO-COBOL  program.  The  MICRO-COBOL 
compiler  and  interpreter  run  on  any  8080  or  Z-80  based 
microcomputer  that  operates  under  CP/M.  The  execution  of  the 
following  four  files  will  cause  a  MICRO-CCBOL  program  to  be 
compiled  and  executed: 

1.  COBOL.COM 

2.  PAFT2.COM 

3.  EXEC.COM 

4.  CINTERP.COM 

These  four  files  are  created  from  the  following  six 
PLM80  source  programs. 

1.  PARTI. PLM 

2 .  PART2 . PLM 

3.  BUILD. PLM 

4.  IREADER.PLM 

5.  INTRDR.PLM 

6.  INTERP.PLM 

The  procedures  used  to  create  the  four  object  files  (COM 
files)   involve  compiling,  linking,  and  locating  each  of  the 
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six  source  files  under  ISIS.  The  SID  program  is  then  used 
under  CP/M  to  construct  the  executable  files.  Each  of  the 
following  steps  describe  the  action(s)  to  be  taken  and, 
where  appropriate,  the  command  string  to  be  entered  into  the 
computer . 

1.  An  ISIS  system  disk  containing  the  PLM80  compiler  is 
placed  into  drive  A  and  a  non-system  disk  containing  the 
source  programs  is  placed  into  drive  B.  It  should  be  noted 
that  drive  A  and  B  are  the  CP/M  reference  names  for  the 
drives  while  Fl  and  F2  are  the  ISIS  reference  names  used  for 
the  associated  disk  drives. 

2.  Compile  the  PLM  source  program  under  ISIS  using  the 
the  following  command: 

PLM60  :Fl:<filename>.PLM  DEBUG  XREF 

DFBUG  saves  the  symbol  table  and  line  files  for  later 
use  during  debugging  sessions.  XRiF  causes  a  cross-reference 
listing,  of  all  identifiers  in  the  source  program,  to  be 
created.  The  cross-reference  listing  includes  each 
identifier  and  the  associated  line  number  where  the 
identifer  was  declared  and  the  line  number  of  each  occurence 
of  the  identifier  in  the  source  program  [9]. 

3.  Link  the  PLM80  object  file. 

LINK  :Fl:<filename>.OBJ,  TRINT.OBJ.  PLM80.LIB,  TO 
:Fl:<f ilename>.MOD 

See  reference  10  for  an  explanation   of   PIM80.LIB.   The 
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TRINT.OBJ   program  interfaces  the  MON1  and  M0N2  functions  of 
CP/M  to  the  source  program,  allowing  for  the  use  of  absolute 
addresses  in  referencing  these  functions. 
4.  Locate  the  object  file. 

LOCATE  :F1  :<f ilename>.MOD  CODE(org  address) 

The  "org  address'  is  the  address  where  the  program  will 
begin  to  be  loaded  into  memory.  The  following  are  "org 
addresses'  for  the  associated  program: 


PARTI. MOD 

100H 

PART2.M0D 

100H 

INTER?. MOD 

100H 

INTRDR.MCD 

80H 

BUILD. MOD 

100H 

IREADER.MOD 

D000H 

The  "org  addresses"  above  represent  the  ones  used  with  a  621 
byte  CP/M  system.  The  only  address  that  would  need  to  be 
changed  if  a  different  size  system  was  used  would  be  the  one 
for  IREADER.MOD.  See  appendix  E  for  specifics  on  the  address 
to  use  for  IREADER. 

4a.  The  two  files  IMTRDR  and  IREJOER  just  created  by  the 
LOCATE  command  must  be  converted  to  "HEX  FILES".  By  using 
the  ISIS  command  OBJHEX  <filename>  the  file  will  be 
converted  to  the  "HEX  file"  <f ilename>.HEX . 

5.  Replace  the  ISIS  system  disk  in  drive  A  with  a  CP/M 
system  disk  and  reboot  the  system. 
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6.  Transfer  the  located  ISIS  file  from  the  ISIS  disk:  on 
drive  3  to  the  CP/M  dis'x  on  drive  A. 

TROMISIS  <filename> 

6a.  When  transfering  the  "HEX  files*'  to  the  CP/M  disk 
use  the  following: 

FROMISIS  <filename>.EEX 

7.  Convert  the  ISIS  file  to  a  CP/M  executable  form. 
OEJCPM  <filename> 

7a.  The  "HEX  files"  are  not  coverted  to  a  CP/M  format, 
but  are  left  in  the  HEX  format. 

At  this  point  the  object  file  is  in  machine  readable 
form  and  will  run  under  CP/M  when  called  properly.  PART2.COM 
and  CINTERP.COM  are  called  by  PART1.COM  (C0E0L.COM)  and 
EXEC.COM,  respectively  and  need  no  further  work.  PART1.COM 
and  EXEC.COM  need  to  be  constructed  from  the  remaining  four 
files. 

PART1.COM  is  created  by  entering  the  following  commands: 

1.  SID  PART1.COM 

2.  I  READER. HEX 

3.  R6200 

4 .  A2A9A 

5.  JMP  0D000 

6.  Control-C 

7.  Save  52  C0B0L.COM 

140 


See  reference  6  for  an  explanation  of  the  I  ',  R'  ,  and 
"a"  commands  used  above  and  ref  4  for  an  explanation  of  the 
'SAVE*  command.  Steps  four  and  five  above  are  used  to  patch 
the  JUMP  to  IREADER  referred  to  in  the  PARTI. PLM  program 
into  the  PART1.COM  program. 

EXEC.COM  us  created  by  entering  the  following  commands: 

1.  SID  BUILD.COM 

2.  INTRER.HEX 

3.  R1C00 

4.  A1CB5 

5.  JMP  5 

6.  A1CC1 

7.  JMP  5 

8.  CONTROL-C 

9.  SAVE  31  EXEC.COM 

Statements  4,  5,  6,  and  7  above  are  used  to  patch  the 
JUMP  to  BDOS  referred  to  in  the  INTRDR.PLM  program  into  the 
INTRDR.HEX  program. 

MPS  MICR0-C030L  programs  may  now  be  executed  in  the 
following  manner.  The  source  program  is  named, 
<f ilename>.CBL.  The  command  "COBOL  <filerame>',  causes  the 
MICRO-COBOL  source  program  to  be  read  into  memory  and 
compiled.  During  the  compilation,  the  intermediate  code 
file,  <f ilename>. C I M ,  is  written  out  to  the  disk  as  the  code 
is  generated.  The  command  'EXEC  <filename>',  causes  the 
file,  <f ilename>  .CIN  ,  to  be  executed. 
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APPENDIX  D 

PART  ONE  AND  PART  TWO  INTERNAL  DATA  STRUCTURES 
AND  SIGNIFICANT  VARIABLES 

Within  PART  ONE  and  PART  TWO,  many  significant  data 
structures  are  used  by  the  procedures  which  constitute  the 
scanner  and  parser.  Descriptions  are  given  below  for  those 
structures  regarded  as  important  and  necessary  for  future 
compiler  development. 

1.   Interfacing  Structures 

ADD^END  —  this  variable  is  used  to  hold  the  end  of 
file  filler  for  the  end  of  the  source  program. 

BUFFER (11)  —  byte  array  used  to  hold  the  filename 
and  filetype  if  declared,  of  an  input  or  output  file  in  the 
SELECT  CLAUSE  of  the  FILE  SECTION  of  a  MICRO-COBOL  source 
program . 

BUFFER^END  —  address  variable  which  marks  the  last 
byte  of  the  compiler  input  buffer  which  is  a  128  byte  buffer 
used  for  reading  the  source  program. 

IN$ADDH  —  address  variable,  default  file  control 
block  used  initially  to  hold  the  <f ilename .C3L>  of  the 
source  program  to  be  compiled. 

IN$BUFF  —  literal  value,  marks  the  first  byte  of 
the  compiler  input  buffer. 

INPUT^FCB  —  byte  value,  based  at  INSADDR(33),  the 
base  address  of  the  default  file  control  block  of  the  source 
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program . 

0UTPUT$PUFF(128)  —  byte  array,  used  as  a  128  byte 
output  buffer  for  loading  the  generated  output  (pseudo 
instructions)  when  writing  to  the  intermediate  code  file. 

OUTPUT$CHAR  —  byte  value,  based  at  the  0UTPUT$PT?.; 
used  to  identify  the  particular  byte  of  the  output  buffer 
(OUTPUT$BUTF)  to  which  the  next  intermediate  code 
instruction  is  to  be  written. 

OUTPUT$END  —  address  variable,  pointer  to  the  end 
of  the  output  buffer  (OUTPUT$BUFF) . 

0UTPUT$FCB(33)  —  byte  array,  the  FCB  for  the 
intermediate  code  file  <f ilename .CIN>  established  in  PART 
ONE  of  the  compiler  and  pasted  to  PART  TWO  of  the  compiler 
by  I READER  module. 

COTPUT$PTR  —  address  value,  used  as  an  index  into 
the  output  buffer  (OUTPUT$BUFF) . 

POINTER  —  address  value,  the  address  of  the  byte 
holding  the  next  input  character  of  the  source  program. 

2.   Debugging  Structures 

DEBUGGING  —  logical  byte  value,  toggle  used  in 
conjunction  with  ":"  in  a  MICRO-COBOL  source  program  text; 
allows  for  the  compilation  or  non-compilation  of  the 
deugging  statements  following  the  ":". 

LIST$INPUT  —  logical  byte  value,  toggle  used  to 
display  or  not  display  a  source  program  to  the  CRT  during 
compilation. 


14; 


PARMLISTO)  —  byte  array  used  to  hold  the  toggles 
set  hy  the  compiler  developer  or  user  upon  execution  of  the 
command:  COBOL  <f ilename.C3L>  ^TOGGLES. 

PRINT$PROD  —  logical  byte  value,  toggle  used  to 
print,  in  chronological  order,  at  the  CRT  the  production 
numbers  of  the  compiler  grammar  rules  used  during  a 
compilation  of  the  source  program. 

SEQ^NUM  —  logical  byte  value,  toggle  used  to 
indicate  the  presence  of  seauence  numbers  in  the  first  six 
positions  of  each  line  of  a  source  program  being  compiled. 

3.   Memory  Structures 

EOEEILLER  —  literal  value,  used  to  test  for  the 
occurrence  of  an  end  of  file  character  ("lAH"  in  CP/M),  when 
reading  the  source  program. 

ERSE$STORAG-E  —  first  free  address  following  PART 
ONE  of  the  compiler?  utilized  as  the  base  of  the  symbol 
table.  This  is  the  same  value  as  HASH$TA3$ADER  in  PART  TWC 
o^  the  compiler. 

INITIALiPCS  —  address  value,  the  initial  location 
of  the  IREADER  module  before  it  is  copied  to  high  memory  at 
location  MAX$MEMORY. 

MAX$MENORY  —  address  value,  the  location  in  hi*h 
memory  where  the  IREADER  module  is  to  be  moved. 

NEXT$AVAILABLE  —  address  value,  the  pseudo  machine 
memory  address  for  the  next  machine  instruction. 

P\rTl$LEN   —   the   number   of   bytes  of  information 
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saved  in  high  memory  after  execution  of  PART  ONE  and  used  to 
initialize  PART  TWO  module  variables  of  the  compiler. 

PASSl$TOP  —  this  address  is  used  in  conjunction 
with  ?ASS1$LEN  for  locating  the  fourty-eight  bytes  of 
information  saved  in  PART  ONE  for  use  in  PART  TWO  of  the 
compiler . 

?DR$LENGTH  —  literal  value  representing  the  255 
bytes  of  the  IREADER  module  to  be  moved  from  IMITIAL^POS  to 
MAX$MEMORY. 

4.   Scanner  Structures: 

ACCUM(51)  —  an  array  of  51  bytes;  the  first  byte 
contains  a  count  of  the  total  number  of  characters  currently 
in  the  accumulator.  This  structure  holds  tokens  as  they  are 
scanned,  and  will  hold  either  a  reserved  word,  a  user 
defined  identifier,  or  a  literal. 

COLLISION  —  address  varible,  contained  in  first  two 
bytes  of  an  identifier's  symbol  table  entry  and  indicates 
whether  there  is  another  identifier  which  hashes  to  the  same 
hash  table  address.  This  address  points  to  that  identifier's 
address  in  the  symbol  table. 

DISPLAY(74)  —  an  array  of  74  bytes?  the  first  byte 
contains  a  count  of  the  total  number  of  characters  (1-73) 
currently  in  the  display  buffer.  Every  line  within  a  source 
orogram  is  loaded  into  this  structure  for  subsequent 
printing  to  the  CRT  terminal  during  compilation. 

SDITiELAG   —   logical   flag   which  denotes  the  fact 
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tbat  a  '$'  symbol  has  been  loaded  into  the  DISPLAY  array 
during  compilation.  When  set  the  characters  within  DISPLAY 
will  be  printed  one  at  a  time,  until  the  entire  line  is 
printed. 

HASH$TABLE$ADDR  —  the  base  of  the  symbol  table 
generated  in  PART  ONE,  used  as  the  base  of  the  hashtable. 

HASH$TAB$ADDR  —  this  was  the  address  of  the  bottom 
of  the  symbol  table  generated  in  PART  ONE  of  the  compiler, 
and  saved  for  Part  two. 

INPUT$STR  —  literal  value  (32),  returned  to  the 
LALR(l)  parser  anytime  the  token  contained  in  the  ACCUM  is 
not  a  reserved  word  or  literal. 

LITERAL  —  literal  value  (15),  returned  to  the 
LALR(l)  parser  anytime  the  first  character  encountered  by 
the  scanner  is  a  quote  ('),  prior  to  loading  the  ACCUM. 

MAX$LEN  —  length  of  the  longest  reserved  word 
allowed  by  MICRO-COBOL. 

5.   Parser  Structures: 

BUEEER(31)  —  byte  array  used  to  store  edited 
PICTURE  CLAUSE  characters  for  subsequent  intermediated  code 
generation. 

COMPILING  —  logical  byte  value  which  indicates  that 
compiling  is  taking  place  or  not  in  PART  ONE  or  PART  TWO; 
set  to  FALSE  whenever  the  statestack  of  the  LALR(l)  parser 
is  reduced  to  a  recognizable  finished  state. 

CURSSYM   —  address  variable  that  holds  the  address 


146 


of  the  current  symbol  being  accessed  in  the  symbol  table. 

DUPSIDEN$ARRAY(24)  —  address  array  that  holds  the 
symbol  address  for  all  files  ieclared  in  the  INPUT-OUTPUT 
SECTION  of  a  source  program.  When  the  FILE  SECTION  entry  for 
the  file  is  encountered  the  array  is  searched  to  determine 
if  the  file  was  declared  and  to  insure  that  a  FILE  SECTION 
entry  had  not  been  previously  made. 

FILESDESC$FLAG  —  logical  byte  value;  indicates 
whether  the  compiler  is  compiling  the  FILE  DESCRIPTION 
SECTION  of  a  source  program  or  not. 

FILE$SEC$END  — logical  byte  value  set  whenever  the 
parser  has  parsed  passed  the  FILE  SECTION  of  a  source 
program. 

H0LD$LIT(51)  —  byte  array,  first  byte  contains  a 
count  of  the  total  number  of  characters  currently  stored  in 
the  HOLDLIT  buffer  which  is  used  to  hold  characters  for  a 
VALUE  CLAUSE. 

ID$STACE(10)  —  address  array  which  functions  as  a 
stack  and  is  used  to  hold  the  addresses  of  identifiers  at 
both  the  record  and  elementary  levels.  Whenever  a  record 
identifier  has  nested  elementary  field  identifiers  it  is 
saved  on  the  ID$STACK.  Also,  anytime  a  record  identifier  has 
succeeding  record  identifiers  redefining  it,  it  is  saved  on 
the  ID$STACK.  In  the  case  of  multiple  record  descriptions  in 
a  file  description  of  the  FILE  SECTION,  the  record 
descriptions  following  the  first  record  are  assumed 
redef ini  tions . 
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ID$STACX$PTR  —  a  byte  index  variable  into  the 
IDiSTACK  array. 

MAX$ID£LEN  —  a  numeric  value  (12),  maximum  length 
of  any  user  defined  identifier. 

MP  —  byte  index  variable  into  the  VALUE  array. 

MPP1  —  byte  index  variable  into  the  VALUE  array, 
one  byte  above  MP  index. 

NEXT^SYM  —  this  address  indicates  the  next 
available  free  space  for  a  symbol  table  entry. 

PENDING$LITERAL  —  byte  value  (0,1,2,3,4,5), 
indicates  the  category  of  the  target  input  to  a  VALUE 
CLAUSE. 

PENDING$LIT$ID  —  byte  value  (0,1,2,3,4,5),  which  is 
saved  to  indicate  the  category  of  the  most  recently 
encountered  target  input  to  a  VALUE  CLAUSE. 

PRODUCTION  —  byte  value,  determined  by  the  parser 
and  indicates  the  next  semantic  action  to  be  taken  by  the 
compiler. 

REEEF  —  logical  byte  value  which  allows  the  testing 
of  an  identifier's  storage  value  size  against  the  storage 
value  size  of  a  second  identifier  that  redefines  the  first. 
Set  to  TRUE  when  there  are  multiple  record  descriptions 
within  a  7D  BLOCK  in  the  FILE  SECTION,  or  when  a  record  or 
elementary  identifier  declaration  in  the  WORDING  STORAGE 
SECTION  contains  a  REDEFINES  CLAUSE. 

REDEF$FLAG  —  logical  byte  value,  used  to  denote  the 
scanning  and   oarsin,?   of   the   FILE   SECTION   of   a   source 
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program,  helps  in  identifying  duplicate  identifiers  within 
this  section. 

REDEF$ONE  —  address  variable  that  holds  the  symbol 
table  address  of  the  identifier  being  redefined  by  another 
identifier. 

REDEESTVC  —  an  address  variable  that  contains  the 
symbol  table  address  of  an  identifier  which  redefines 
another  identifier. 

SP  —  a  byte  index  for  the  STATESTACK  array  and  the 
VALUE  array;  points  to  the  top  of  the  STATESTACK  array. 

STATE  —  a  byte  value  numeric  quantity  that 
indicates  the  current  parser  state. 

STATES TACI (30)  —  a  byte  array  which  stacks  the 
states  (production  sequences)  the  parser  passes  through 
while  compiling  a  source  program. 

TF.UNC$ELAG  —  logical  byte  value  that  indicates 
numeric  truncation  of  an  identifier's  VALUE  CLAUSE  input 
hasn't  occurred,  because  the  identifier's  associated  PICTUFE 
CLAUSE  has  not  been  scanned  and  parsed. 

VALUE(30)  —  an  address  array  that  holds  addresses 
of  identifiers,  specific  attributes  of  these  identifiers  and 
attributes  of  the  current  source  program  statement  or 
sentence  being  parsed. 

VARC(51)  —  a  byte  array,  the  first  byte  holds  the 
count  of  the  total  number  of  characters  within  it,  used  to 
hold  all  the  ASCII  characters  of  tokens  scanned  within  the 
source   program,   excluding   reserved   words?  for  subsequent 
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analysis  and  processing. 

VALUESFLAG-  —  a  logical  byte  that  is  set  anytime  ar. 
identifier  has  an  associated  VALUE  CLAUSE;  used  primarily  to 
recognize  the  occurrence  of  a  PICTURE  CLAUSE  before  the 
VALUE  CLAUSE  or  when  a  record  entry  has  a  VALUE  CLAUSE,  hut 
no  associated  PICTURE  CLAUSE  except  for  those  in  its 
elementary  field  identifiers. 

VALUESLEVEL  —  a  byte  value  which  saves  the  level 
number  of  a  record  identifier  which  doesn't  have  an 
associated  PICTURE  CLAUSE. 
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APPENDIX  E 

The  NPS  MICRO-COBOL  compiler/interpreter  is  designed   to 

operate  on  any  8080  or  Z80  based  microcomputer  operating 
under  CP/M  with  at  least  2eX  bytes  of  memory.  The  PLM80 
source  files  have  been  written  in  such  a  way,  that  certain 
variables  must  be  altered  in  the  source  cole  to  take 
advantage  of  the  machine  that  the  programs  are  going  to  be 
operating  on.  This  appendix  covers  those  programs  and  the 
variables  that  must  be  altered. 

1.  PART1.PLM 

This  program  has  two  variables  that  are  memory  size 
dependent,  MAXSMEMORY  and  M.4X$INTSMEM0RY.  The  variable 
MAXSMEMORY  is  set  to  100H  bytes  below  the  base  of  the  3L0S 
and  is  used  for  the  beginning  address  of  the  IREADER 
routine.  The  variable  MAX$lNTSMEMORY  is  set  to  the  base 
address  of  the  BDOS  and  is  used  as  the  upper  limit  for  the 
intermediate  code  file. 

2.  PART2.PLM 

This  program  also  has  two  variables  that  are  memory  size 
dependent,  MAXSMEMORY  and  PASSISTOP.  In  this  program 
MAX$MEMORY  is  set  to  the  base  address  of  the  BDOS  while 
?ASS1$T0P  is  set  to  100H  bytes  below  the  base  of  the  3DC3  . 

3.  IREADER.PLM 

Although,  this  program  does  not  have  any  memory  size 
dependent  variables  the  program  must  be  modified  to  execute 
properly.  When  using  the  LOCATE  command,  under  ISIS,  this 
routine  must  be  located  100H  bytes  below   the   BIOS   of   the 
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system.   This   address   would   correspond   to   the  values  of 
MAX$MEMORY  in  PART2.PLM  and  MAXS INTSMEM0R7  In  PARTI. PLM. 

4.  INTERP.PLM,  INTRDR.PLM,  and  BUILD. PLM 

These  three  programs  have  no  variables  that  need  to  be 
altered. 

5.  GENERAL  INFORMATION 

The  current  version  of  the  NFS  MICRO-COBOL 
compiler/interpreter  is  designed  for  continued  development 
and  certain  variables  are  not  set  to  make  optimal  use  of 
memory.  The  variable  NEXTHVAILABLE ,  in  PARTI. PLM,  is  set  to 
3002E  and  CODE$START,  in  INTER?. PLM,  is  set  to  3000H. 
Normally,  CODE$START  would  be  set  to  the  address  immediately 
following  the  last  address  in  CINTERP.CCM  and  NTXTS AVAILABLE 
would  be  set  two  bytes  above  that  address.  These  address  are 
currently  set  approximately  950H  bytes  above  whe-e  they 
should  be  located,  to  allow  for  testing  and  expansion  of  the 
interpreter.  As  soon  as  implementation  is  completed  these 
two  addresses  can  be  reset  to  appropriate  valaes. 
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APPENDIX  F 
MICRO-COBOL  Parse  Table  Generation 

The  parse  tables  for  NPS  Micro-Cobol  were  generated  on 
the  IBM  360  using  the  LALR(l)  parse  table  generater 
described  in  reference  1?.  There  are  basically  two  steps 
involved  in  generating  the  tables.  First,  a  deck  of  cards 
containing  the  grammar  is  entered  into  the  computer  using 
the  following  JCL: 

//GO    EXEC    PGM=   ULR,REGION=220K 

//STEPLIE  DD  DSN=F0963.LALR,UNIT=2314:, 
VOL=SER=LlNDA, DISPOSER 

//SYSPRINT  DD  STS0UT= A, DCB=(RECFM=FB , 
LRECL=133,3LKSIZS=3325) , 

//SPACE=(CYL,(1,1)) 

//NONTERM  DD  SPACE= (CYL , ( 1 , 1 ) ) ,UN I T=SYSDA 

//FSMDATA  DD  S?ACE= (CYL , ( 1 , 1 ) ) ,UN I T=S YSDA 

//PTAELES  DD  SYSOUT=B, 

DCB=(?ECFM=FB,LRECL=80,3LXSIZS=3P7') 

//SYSIN  DD  * 

The  ouput  from  this  run  is  a  listing  and  a  card  deck 
containing  the  tables  in  XPL  compatable  format.  This  deck  is 
then  translated  into  PLM  compatible  format  using  the 
following  JCL  and  an  XPL  urogram  which  is  available  in  the 
card  deck  library  in  the  Computer  Science  Department  at  the 
Naval  Postgraduate  School. 

//EXEC  XCOM 
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//COMP.SYSIN  DD  * 

//GO.SYSPUNCH  DD  SYSOUT=B, 

DCB=(RECFM=FBfLRECL=80,3LKSIZE=800) 

//GO.SYSIN  DD  * 

The  tables  are  then  transferred  to  a  diskette  and  edited 
into  the  PLM80  source  program  using  the  ISIS  COPY  and  EDIT 
features  on  the  INTEL  MDS  System. 
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APPENDIX  G 
LIST  OF  INOPERATIVE  CONSTRUCTS 

The  following  is  a  list  of  MICRO-COEOL  elements  that 
either  have  not  been  implemented  or  have  been  implemented 
incorrectly. 

LINKAGE  SECTION 

USAGE  COMP 

{LEAUNG} 
SIGN  SEPARATE 

{TRAILING} 

{LEFT} 
SYNC 

{RIGHT} 

ADD 

DI7IDF 

DELETE 

EXIT 

MOVE 

MULTIPLY 

SU3TRACT 

The  following  EYPO-COBOL  elements  are  part  of 
MICR0-CC3CL  only  to  the  extent  that  they  are  defined  in  the 
grammar.  No  code  has  oeen  written  to  support  them. 

USING 

CALL 

ENTER 
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{BEFORE}  {INTEGER} 

WHITE   record-nane  ADVANCING 

{AFTER}  {PA1E} 
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COMPUTER    LISTINGS 


PARTI: 

do; 

/*  normally  org'ed  at  100h  */ 


/* 


/* 


COBOL  COMPILER  -  PART  1 

GLOBAL  DECLARATIONS  AND  LITERALS 


*/ 

*/ 


DECLARE  LIT  LITERALLY  'LITERALLY'; 
DECLARE 


PARMS 

LIT 

.  '6DH', 

PARMLIST(9) 

BYTE 

INITIAL* 

')• 

EOFFILLER 

LIT 

'1AH', 
/*  END  OF 

RECOPD  FILLER  */ 

MAX^MEMORY 

LIT 

'0D000H', 
/*  TOP  OF 

'useable  MEMORY  */ 

INITIAL$POS 

LIT 

'3200H', 

RDR$ LENGTH 

LIT 

'255', 

PASS1$LEN 

LIT 

'48', 

CR 

LIT 

'13', 

LF 

LIT 

'10', 

QUOTE 

LIT 

'27H', 

POUND 

LIT 

'23H', 

TRUE 

LIT 

'1', 

FALSE 

LIT 

'0', 

FILE$DESC$FLAG 

BYTE 

INITIAL(FALSE) , 

REDEFSFLAG 

BYTE 

INITIAL(FALSE) , 

DUP$IDEN$ARS 

:AY( 

ADDRESS 

INITIAL(0, 0,0,0, 

0, 

0,0,0  ,0 

,0,0,0,3,0,0, 

,0,0,0,0,0,0,0,0,0), 

FOREVER 

LIT 

'WHILE  TRUE'; 

DECLARE  MAXRNO  LIT 
MAXLNO  LIT 
MAXPNO  LIT 
MAXSNO  LIT 
STARTS  LIT 

DECLARE  RSAD1  (*)  3YTE 

DAT A( 0,57, 48, 56, 32, 3, 25 

,38,34,44,9,19,32,37,6, 

,38,36,43,1,1,1,1,1,1,1 

,1,38,23,24,55,52,41 

,1,32,1,32,1,32,47,37,4 

,32,5,12,13,21,22,27,1, 

DECLARE  LOOKK*)  BYTE 

DATA(0,8,0,25,0,9,19,0, 

,0,4,?, 54, 0,40, 0,35, 46, 

32,0,32,0,32,0); 

DECLARE  APPLYK*)  BYTE 

DATA(0, 0,0, 0,0, 0,9, 10,1 

,0,0,0,0,0,97,0,27,0,0, 


'104',/*  MAX  READ  COUNT  */ 

'129',/*  MAX  LOOK  COUNT  */ 

'145',/*  MAX  PUSH  COUNT  */ 

'234',/*  MAX  STATE  COUNT  */ 

'1  ';/*  START  STATE  */ 


,59,2,16,17,22,29,53,58,11,32,32,39 

33,3,14,15,18,20,32,28,49,32,1,42 

,1,1,10,1,39,1,1,1,38,40,49,33,39,1 

, 35 , 46 , 1 , 7 , 50 , 1 , 32 , 1 , 32 , 32 , 4  5 
,26,32,54,40,1,1 
60,1,23,24,55,30,51); 

42,0,42,0,1 ,0,52,0,41 ,0,35,0,1 ,0,47 
60,0,1,0,32,0,1,0,1,0,11,0,60,0,7,0 


2, 14,19,0,0,0,0,0,0,101,0,0,100,0 
0,69,0,91,92,0,0,91,92,0,0,0,0,13 
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,17,0.102      ,103,104,0,0,0,0,0,95,0,0,54,0,0,23,30,38,39,0 

,21,40,52,56,87,93,94,0); 

DECLARE  READ2(*)  BYTE 

DATA (0,65, 57, 64, 154, 26, 37, 67, 21, 30, 31 ,33,39,61,66,27,234 

,215,51,45,108,109,223,224,233,43,216,217,22,230,229,232 

,231,228,173   ,172,169,9,226,47,196,195,7,8,11,13,15,2,3,105 

,14,158,4,50,20,12,18        ,48,171,170,44,49,19,10,46,35,36 

,63,60,53,42,146,16,25,58,106,155     ,148,155,155,55,150,155 

,152,155,157,155,56,193,23,208,234,62,52,206 

,180,234,24,28,107,32,34,38,17,63,164,35,36,63,40,59); 

DECLARE  L00K2(*)  BYTE 

DATA (0,5, 130, 6, 131, 29, 29, 132, 41, 133, 54, 134, 135, 69, 71, 136 

,72,137,73,138,139,80,84,140,86,198,88,141  ,89,142184,184 

,184,91,189    ,92,93,197,211,95,143,96,97,176,99,144,145,101 

,102,200,103,202,104,188) ; 

DECLARE  APPLY2(*)  BYTE 

DATA (0,0, 77, 11 1,112, 147, 79, 114, 81, 82, 33, 73, 76, 117, 75, 156 

,126,163,162,100,166.165,167,118,168,160,124,179,178,94 

,121,74,125       ,120,119,187,187,186,98,192,192,191,194,113 

,183,128,129,127,205,205  ,205,204,115,123,90,122,214,213,221 

,219,216,222,199,85,220,116,87        ,110,70,174,209,207,182 

,182,181); 

DECLARE  INDEXK*)  BYTE 

DAT  A (0,1, 2, 3, 4, 5, 6, 7, 3, 4, 4, 24, 4, 24, 4, 13, 14, 24, 109, 4, 15, 16 

,16, 24, 17, 18, 19, 16, 20, 22, 24, 25, 26, 28, 29, 34, 36, 37, 24, 24, 16 

,38,39,40    ,42,43,44,45,46,47,48,49,16,50,38,51,16,52,53,54 

,55,56,57,58,60,61  ,62,63,64,8,65,68,69,70,71,72,73,74,75,77 

,79,81,83,85,87,86,89,90,92     ,93,94,8,8,16,95,97,97,15,103 

,104,105,109,24,24,24,1,3,5,8,10,12,14  ,16,13,20,22,24,26,28 

,30,34,36,38,40,42,44,46,48,50,5  2,185,149,225 

,227,227,190,151 

,153,203,159,210,161,175,212,201,177,1,2,3,3,4,4,5,5  ,6,6,12 

,13,14,14,15,15,16,16,17,19,19,20,20,20,22,22,23,23,24,24,25 

,25,26,26,27,29,29,31,32,32,33,33,3  5,38,38,33,33,39,39,39 

,39,39,42    ,42,43,43,44,44,45,45,48,52,52,53,53.54,54,55,55 

,56,56.56,56,56,56       ,56,56,58,58,58,59,59,61,61,61,61,61 

,62,67); 

DECLARE  INDEX2(*)  BYTE 

DATA (0,1, 1,1, 1,1, 1,1, 5, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1,1 

,1,1,2,2,1,1,2,1,5,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1 

,1,1,1,1,1   ,1,1,1,2,1,1,1,1,1,5,3,1,1,1,1,1,1,1,2,2,2,2,2,2 

,1,1,1,2,1,1,1,5,5,1     ,2,6,6,1,1,1,4,2,1,1,1,2,2,3,2,2,2,2 

,2,2,2,2,2,2,2,4,2,2,2,2,2,2,2,2   ,2,2,5,6,29,41,54,69,71,72 

,73,80,84,88,89,96,99,101,3,9,3,0,3,0,3,0    ,0,1,7,8,1,0,6,0 

,0,1, 3, 0,1, 1,2, 1,0, 0,0, 0,1, 0,2, 0,0, 1,2, 0,1, 5, 3, 0,0,1   ,4,0,0 

,0,1, 2,1, 2, 2, 2, 0,2, 3, 0,3, 0,0, 1,4, 0,0, 1,0, 0,0, 0,1, 1,1, 1,2, 2,1 

,1,1,0,0,0,0,0,0,0,0,0,0,0,0);  /*  END  CF  TABLES  */ 

DECLARE 

/*  JOINT  DECLARATIONS 

THESE  ITEMS  ARE  DECLARED  TOGETHER  IN  TEIS  SECTION 

IN   ORDER    TO    FACILITATE   THEIR    BEING    SAVED    FOR 

THE  SECOND  PART  CF  THE  COMPILER.  */ 

OUTPUT$?CB      (33)  BYTE 
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INITIALS,  ' 

', 'CIN',0, 0,0,0), 

DEBUGGING 

3YTE 

INITIAL  (FALSE), 

PRINT$PR0D 

BYTE 

INITIALS  FALSE), 

PRINT$TOKEN 

BYTE 

INITIAL(FALSE), 

LIST$INPUT 

BYTE 

INITIAL  (TRUE), 

SEQ$NUM 

BYTE 

INITIAL  (FALSE), 

NEXT$SYM 

ADDRESS, 

POINTER 

ADDRESS 

INITIAL  (100H), 

NEXT$AVAILABLE 

ADDRESS 

INITIAL  (3002H), 

MAX$INT$MEM 

ADDRESS 

INITIAL  (0D100H) 

FREESSTORAGE 

ADDRESS, 

FILE:?SEC$END 

BYTE 

INITIAL  (FALSE), 

/*   I  0  BUFFERS  AND  GLOBALS  */ 
IN$ADDR  ADDRESS  INITIAL  (5CH), 
INPUT$FCB  BASED  INADDR  (33)  BYTE, 
OUTPUT$PTR   ADDRESS, 
OUTPUTiBUFF  (128)  BYTE, 
OUTPUT$END  ADDRESS, 
OUTPUT$CEAR  BASED  OUTPUT$PTR  3YTEJ 


MON1:  PROCEDURE  (F,A)  EXTERNAL; 

DECLARE  A  ADDRESS,  F  BYTE* 
END  MONi; 

M0N2:  PROCEDURE  (F,A)  BYTE  EXTERNAL; 

DECLARE  F  BYTE,  A  ADDRESS? 
END  M0N2J 

BOOT:  PROCEDURE  EXTERNAL; 
DECLARE  A  ADDRESS? 

END  boot; 

PRINTCHAR:  PROCEDURE  (CHAR); 

DECLARE  CHAR  BYTE; 

CALL  MONI  (2, CHAR); 
END  PRINTCHAR,* 

CRLF:  PROCEDURE; 

CALL  PP.INTCHAE(CR); 

CALL  PRINTCHAR(LF); 
END  CRLF J 

PRINT:  PROCEDURE  (A) J 
DECLARE  A  ADDRESS; 
CALL  MONI  (9, A); 

END  print; 

PRINT$ERROR :  PROCEDURE  (CODE); 

/*  THIS  PROCEDURE  IS  USED  TO  PRINT  COMPILER  ERRORS  TO 
CONSOL  */ 
DECLARE  CODE      ADDRESS, 
I         BYTE, 
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c0dek6)  address; 
if  code  =  false  then 
do; 

DO  I  =  0  TO  5J 

CODEKI)  =  0; 

end; 
1=0; 
end; 

ELSE 

if  code  =  true  then 
do; 

1  =  0; 

DO  WHILE((I  <>  6)  AND  (  CODEl(I)  <>  0)); 
CALL  crlf; 

CALL    PRINTCFAR(HIGH(C0DE1(I))); 
CALL    PRINTCHARILOW    (CODEl(I))); 
CODEKI)    =    0; 
1=1+1; 

end; 

I    =   0; 

end; 

ELSE 

IF  (CODE  =  'N?')  OR  (CODE  =  'SL')  OR  (CODE  =  'NV')  THEN 

do; 

call  crlf; 

call  printchar(high(cods)); 

call  printcharuow(code)  ) ; 
end; 

ELSE 

do; 

IF  I  <>  6  THEN 

do; 

CODEKI)  =  code; 

1=1+1; 
end; 

end; 
end  print$error; 

fatal$er?.or:  procedure(  re ason  )  j 
declare  reason  address; 
call  prlnt$error(reason); 
call  print^error(true) j 
call  timeu0); 

CALL  300TJ 

end  fatal$error; 

OPEN:  PROCEDORE; 

IF  M0N2  (15,IN$ADDR)=255  THEN  CALL  FATAL^ERROR ( 'OP' ) ; 
END  open; 

MORE$INPUT:  PROCEDURE  BYTE; 

/*  READS  THE  INPUT  FILE  AND  RETURNS  TRUE  IF  A  RECORD 

WAS  READ.   FALSE  IMPLIES  END  OF  FILE  */ 
DECLARE  DCNT  BYTE; 
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IF  (DCNT:=MON2(20,.INPUT$FCP))>1 

THEN  CALL  FATAL$ERROR( 'BR  ' ) ; 
RETURN  NOT(DCNT) J 

END  more$input; 

MAKE:  PROCEDURE; 

/*  DELETES  ANY  EXISTING  COPY  OF  THE  OUTPUT  FILE 

AND  CREATES  A  NEW  COPY*/ 
CALL  M0N1(19,.0UTPUT$FCB); 
IF  M0N2(22,.0UTPUT$FCB)=255  THEN  CALL  FATAL$ERROR ( 'MA  '  )  ; 

END  make; 

WP.ITE$OUTPUT:    PROCEDURE? 

/*   WRITES    OUT    A   BUFFER    */ 

CALL   MONK 26,. OUTPUT* BUFF)!  /*   SET    DMA   */ 

IF   MON2(21..OUTPUT$FCB)<>0    THEN    CALL    FATAL$ERROR(  'WR  ' )  ; 
CALL    MON1(26,80H);  /*   RESET    DMA   */ 

END   WRITE$OUTPUTJ 

MOVE:    PROCEDURE (SOURCE,    DESTINATION,    COUNT); 

/*   MOVES    FOR    THE    NUMBER    OF   BYTES   SPECIFIED   BY    COUNT   */ 
DECLARE    (SCURCE, DESTINATION)    ADDRESS, 

(SiBYTE   BASED    SOURCE,    D$BYTE    BASED    DESTINATION,    COUNT) 
BYTE  * 

do  while  (ccunt:=count  -  1)  <>  255; 

d$byte=s$byte; 

source=source  +1 ; 

destination  =  destination  +  15 
end; 
end  move; 

fill:  pr ocedure(addr, char, count); 

/*  moves  cbar  into  addr  for  count  bytes  */ 
declare  addr  address, 
(char, count, test  based  addr)  byte  j 
do  while  (count:=count  -1)<>255j 
dest=char; 
addr=addr  +  1j 
end; 
end  fill; 


/*   *  *   *   #  * 

SCANNER  LI 

ARE 

LITERAL 

LIT 

'15', 

INPUT^STR 

LIT 

'32', 

PERIOD 

LIT 

'1\ 

INVALID 

LIT 

'0'; 

/*   *  *  *  *  SCANNER  TABLES  *  *  *  *    */ 
DECLARE  TOKEN$TABLE  (*)  BYTE  DATA 

/*  CONTAINS  THE  TOKEN  NUMBER  ONE  LESS  THAN  THE 
FIRST  RESERVED  WORD  FOR  EACH  LENGTH  OF  WORD   */ 
( 0,0, 1,4, 5, 15 ,22 ,32 .38, 44, 47, 49 ,5 1,55, 56, 57 ) , 


161 


TABLE  (*}  BYTE  DAT  A (  'FD ', 'OF ' , 'TO ' , 'PIC ' , 'COMP ' ,  'DATA  ' , 'FILE ' 

, 'LEFT', 'MODE', 'SAME', 'SIGN', 'SYNC', 'ZERO'  /BLOCS', 'LABEL' 

,  'QUOTF','PIGHT', 'SPACE', 'USAGE' , 'VALUE ' , 'ACCESS',  'ASSIGN' 

, 'AUTHOR',  'FILLER', 'OCCURS', 'RANDOM', 'RECORD', 'SELECT' 

, 'DISPLAY', 'LEADING', 'LINK AGE', 'OMITTED', 'RECORDS' 

, 'SECTION', 'DIVISION', 'RELATIVE', 'SECURITY', 'SEPARATE' 

,  'STANDARD',  'TRAILING',  'DEBUGGING', 'PROCEDURE', 'REDEFINES' 

, 'PROGRAM-ID', 'SEQUENTIAL',  'ENVIRONMENT', ' I-O-CONTROL ' 

,'DATE-WPITTEN', 'FILE-CONTROL ',' INPUT-OUTPUT ' , 'ORGANIZATION' 

,  'CONFIGURATION',  'IDENTIFICATION', 'OBJECT-COMPUTER' 

, 'SOURCE-COMPUTER', 'WORKING-STORAGE') , 

OFFSET   (16)  ADDRESS 

/*   NUMBER  OF  BYTES  TO  INDEX  INTO  THE  TABLE 

FOR  EACH  LENGTH  */ 
INITIAL  (0,0,0,6,9,45,80,128,170,218,245,265, 
287,335,348,362) , 

WORD^COUNT  (*)  BYTE  DATA 

/*  NUMBER  OF  WORDS  OF  EACH  SIZE  */ 
(0,0,3,1,9,7,8,6,6,3,2,2,4,1,1,3), 


MAX^LEN 

LIT 

'16', 

ADD$END(*) 

BYT 

E  DATA 

('PROCEDURE  '), 

LOOKED 

BYTE 

INITIAL  (0), 

HOLD 

BYTE, 

BUFFER$END 

ADDRESS 

INITIAL    (100H), 

NEXT 

BASED 

POINTER   BYTE, 

IN3UFF 

LIT 

'80H', 

CHAR 

BYTE, 

ACCUM$LENG 

LIT 

'50', 

ACCUM$LEN$P^1 

LIT 

'51', 

/*  =  TO  ACCUMSLENG  PLUS  1  */ 

ACCUM  (ACCUM$LEN$?$1)  BYTE, 

DISPLAY(74)     BYTE       INITIAL  (0), 

TOKEN  BYTE,  /^RETURNED  FROM  SCANNER  */ 

EDIT5FLAG       BYTE      I.MIT  IAL  (  FALSE  )  J 


/*****    PROCEDURES  USED  3Y  THE  SCANNER  *  *  *  */ 

next$char:  procedure  byte? 
if  looked  then 
do; 

lookee=false; 
return  (char:=hold); 
end; 

if  (?ointer:=pointer  ♦  1 )  >=  buffer$end  then 
do; 

if  not  more$input  then 
do; 

buffer$end=. memory; 
?ointer=. add$end; 
end; 
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else  pointer=inbuff; 
end; 

if  next  =  eoffiller  then 
do; 

buffer$end  =  .memory; 

pointer  =  .add$end; 
end; 

RETURN  (CHftR:=NEIT) ; 

end  next  $ char; 

get$cear:  procedure; 

/*  this  procedure  is  called  when  a  new  char  is 
needed  without  the  direct  return  of  the  character*/ 
char=next$char; 

END  get^cear; 

display$line:  procedure  j 
declare  i  byte? 
if  not  list^input  then  return; 
if  not  edit$flag  then 
do; 

display(display(0)  +  1)  =  '$'; 
call  print(  .display(l)); 
end; 
else  do  i  =  1  to  display(0); 

call  printchar(display(i )); 
end; 
displays)  =  0; 
edit$flag  =  false; 

END  DISPLAYiLlNE; 

LOAD$DISPLAY:  PROCEDURE; 

IF  DISPLAYO)  <  72  THEN 

DISPLAY(DISPLAY(0) :=DISPLAY(0)  +  1)  =  CHARJ 

IF  CHAR  =  '$'  THEN  EDIT$FLAG  =  TRUE? 

CALL  get$char; 
end  load$eisplay; 

PUT:  procedure; 

if  accum(0)  <  accum$leng  then 

accum(accum(0) :=accum (0 ) +1 )=charj 

call  load$display; 
END  put; 

EATiLlNE:  PROCEDURE; 

do  while  charocr; 

call  loadsdisplay; 
end; 
end  eat$line; 

get$no$blank:  procedure; 
declare  (n,i)  byte; 
DO  forever; 

IF    CHAR    =    '     '    THEN    CALL    LOAD$OIS?LAY; 
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ELSE 

if  char-cb  then 
do; 

CALL  displaysline; 

CALL  PRINT$ERROR(TRUE); 

IF  SEQ$NUM  THEN  N=8;  ELSE  N=2; 

DO  I  =  1  TO  NJ 

call  load$dis?lay; 
end; 
ie  char  =  '*'  then  call  eat$linej 

ELSE 

if  char  =  ':'  then 

do; 

if  not  debugging  then  call  eat$line; 

else  call  load$display; 
end; 
end; 

ELSE 

return; 
end;   /*  end  of  do  forever  */ 
end  get$no$blank; 

space:  procedure  byte; 

return  (char='  ')  or  (char=cr); 
END  space; 

delimiter:  procedure  byte; 

/*  checks  for  a  period  followed  by  a  space  or  crv 

if  char  <>   '.'  then  return  false; 

hold=next$char; 

looked=true; 

if  space  then 

do; 

char  =  '.'; 
return  true; 

end; 

char=\  '; 

return  false; 
end  delimiter; 

end$of$toxen:  procedure  byte? 

return  space  or  delimiter; 
end  end$of$token; 

get$literal:  procedure  byte; 
CALL  load^display; 
do  forever; 

if  char=  quote  then 
do; 

call  load^display; 
return  literal? 
end; 

call  put; 
end; 
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end  get$literal; 

lock$up:  procedure  eytej 
declare  point  address, 
here  based  point  (1)  byte, 
I  byte; 

MATCH:  PROCEDURE  BYTE? 
DECLARE  J  BYTE? 
DO  J=l  TO  ACCUMO); 

if  hsreu  -do  accum(j)  then  return  falsej 
end; 

return  true; 
END  match; 

point=offset(accum(0) )+  .table? 
do  1=1  to  word$count( accum(0) ) ; 

if  match  then  return  i j 

point  =  point  +  accum(0) j 
end; 

return  false? 
end  look-up; 

reserved$word:  procedure  byte; 

/*  returns  the  toon  number  of  a  reserved  word  if  the 
contents  of  the  accumulator  is  a  reserved  word,  otherwise 
returns  zero  */ 
declare  value  3ytej 
declare  numb  byte; 

if  accum(0)  >  max$len  then  return  0j 

if  (numb:=token$ta3ls(accum(0) ) )=0  then  return  0j 

if  (value:  =  look!?up)  =  0  then  return  0j 

return  (numb  +  value) j 
end  reserved$wcrd; 

gst$token:  procedure  byte? 

ACCUM(0)=0J 

call  get$no$blanx; 

if  char=0u0te  then  return  get^literalj 

if  dflimiter  then 

do; 

CALL  put; 

return  period? 
end; 
do  forever; 

CALL  PUT* 

IF  END$OF$TOKEN  THEN  RETURN  INPUT^STR; 
END;  /*  OF  DO  FOREVER  */ 
END  get$token; 

scanner:  procedure; 
declare  check  3yte; 
do  forever; 

if(token:=get$token)  =  input^str  teen 
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IF  ( CHECK :=RESERVED$WORD)  <>  0  THEN  TOKEN=CHECK; 
IF  TOKEN  <>  0  THEN  RETURN; 
CALL  PRINT$ERROR  ( 'SE') J 
DO  WHILE  NOT  END$OF*TOKEN J 

CALL  get$char; 
end; 
end; 
end  scanner; 

print$accum:  procedure; 
a.cc0m(accuk0)+1  )  =  '$'» 

CALL  PRlNT( .ACCUM(l)); 

END  print$accum; 

PRINT$NUMBER:  PROCEDURE ( NUMB ) ; 

DECLARE(NUMB,I,CNT,K)  BYTE,  J(*)  BYTE  DATA ( 100. 10 ) J 
DO  1=0  TO  i; 
CNT=0J 

DO  WHILE  NUMB  >=  (K:=J(I)); 
NUMB=NUMB  -  K; 
CNT=CNT  +  15 

end; 

call  printcharc0'  +  cnt); 
end; 

call  printchar( '0'  +  numb); 
end  pr  in t$ number ; 

init$scanner:  procedure; 

/*    initialize  for  input  -  output  operations    */ 
declare  con$cbl  (*)  byte  data  ('cbl'), 

I  BYTE, 

testflag   byte? 
call  move(parms, .parmlist,s) ; 
if  ?armlist(0)  =  '$ '  then 
do; 
I  =  0; 

DO  WHILE  (TSSTFLAG:=PARMLIST(I :=I+1) )  <>  '  'j 

if  testflag  =  'l '  then  list$ in?ut=not  list$in?ut; 

if  testflag  =  's '   then  seq$num=  not  se03num; 

if  testflag  =  'p '  then  prlntiprod  =  not  print^prodj 

if  testflag  =  't  '  then  pp.int$token  =  not  ppintstokenj 
end; 
end; 

call  move  (.conscbl,  iniaddr  +  9,  3); 
call  fill(in$addr  +  12,0,5); 
CALL  open; 

CALL  MOVE( INADDR,.0UTPUT$FCB,9); 
0UTPUT$FCB(32)  =  0; 

0UTPUT$END=(0UTPUTiPTR:=.CUTPUT^3UFF  -  1)  +  128J 
CALL  make; 

CALL  GET$CHAR?     /*  PRIME  THE  SCANNER  */ 
IF  SEQ^NUM  THEN 
DO  I  =  1  TO  6; 

CALL  load$display; 
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end; 

if  char  =  '*'  then  call  eat$linej 
call  get$n0$3lankj 

call  print$error(false);   /*  initializes  error 

msg  output  */ 

END  INITiSCANNER? 

/*   *   *   *   END  OF  SCANNER  PROCEDURES   *   *   * 
/*****   SYMBOL  TABLE  DECLARATIONS  *  *  * 


*/ 
*/ 


DECLARE 
CUR$SYM 

SYMBOL 

SYMBOL$ADDR 

NEXT$SYM*ENTRY 

HASH$PTR 

SAVE$ADDR 

DISPLACEMENT 

HASH$MASK 

SiTYPE 

OCCURS 

ADDR2 

P^LENGTH 

SSLENGTH 

LEVEL 

DECIMAL 

LOCATION 

REL$ID 

START$NAME 

MAX$ID$LEN 


ADDRESS, 

BASED  CUR$SYM 

BASED  CUR$SYM 

BASED  NEXT$SYM 

ADDRESS, 

ADDRESS, 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 

LIT 


/^SYMBOL  BEING  ACCESSED*/ 
( 1 )   BYTE  , 
(1)  ADDRESS, 

ADDRESS, 


'13', 

'3FH' 

'2', 

'12', 

'4', 

'3', 

'3', 

'10', 
'11', 

'2;> 

'5', 

'12', 

'12'; 


/*1  LESS*/ 


/* 


*   *   *   TYPE  LITERALS  ********/ 


DECLARE 

SEQUENTIAL  LIT 

S2Q$RELATIVE  LIT 

RANDOM  LIT 

VARIABLE$LENG  LIT 

GROUP  LIT 

COMP  LIT 


'2', 

'3', 

'4', 
'6', 

'2i'; 


/*   *   *   *   SYMBOL  TABLE  ROUTINES   *   *   *   */ 

INIT$SYMBOL:  PROCEDURE; 

/*  INITIALIZE  HASH  TABLE  AND  FIRST  COLLISION  FIELD  */ 

FREE$STORAGE  =  .MEMORY; 

CALL  FILL  vFREE^STORAGE, 0,130); 

NEXT$SYM=FREEiST0RAGE+128; 

NEXT$SYM$ENTRY=0; 
END    INIT$SYMB0LJ 

GET$P$LENGTH:    PROCEDURE   BYTE? 
RETURN    SYMBOL(P$LENGTH); 
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end  get$p$length; 

set$address:  procedure ( addr ) j 
declare  addr  address; 

s ymbol$ addr ( location )=addrj 
end  set$address; 

get$address:  procedure  address; 

return  symbol$addr( location) ; 
end  get* address; 

get$type:  procedure  byte; 
return  symbol(s$type) ; 
END  get$type; 

set$type:  procedure! type) j 

declare  type  byte; 

symbol(s$type)=type; 
end  set$type; 

OR$TYPE:  procedure(type); 

declare  type  byte? 

symbol(s$type)=type  or  get$ty?e; 
end  or$type; 

get^level:  procedure  byte; 
return  symbol (level); 
end  get$level; 

set$level:  procedure  (lvl)j 

declare  lvl  byte; 

sympol(level)=lvl; 
end  set^level; 

get$decimal:  procedure  byte; 
return  symbol(decimal) ; 
end  get$decimal; 

set$decihal:  procedure  (dec); 
declare  dec  byte; 

SYMBOL(DEClMAL)=DEC; 

END  set$decimal; 

SET$S$LENGTH:  PROCEDURE (HOW$LONG  )  ; 
DECLARE  HOW$LONG  ADDRESS; 
3YMBOL$ADDR(S$LENGTH)  =  HOW$LONGJ 

END  set$s$length; 

GET$S$LSNGTH:  PROCEDURE  ADDRESS; 
RETURN  SYMBOL^ADDRf  SHENGTH); 

END  get$s$length; 

SET$ADDR2:  PROCEDURE  (ADDR); 
DECLARE  ADDR  ADDRESS; 
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SYMB0L$ADDR(ADDR2)=ADDR; 
END  SET$ADDR2; 

GET$ADDR2:  PROCEDURE  ADDRESS? 

RETURN  SYMBOL!?  ADDR(  ADDR2  )  J 
END  GET$ADDR2; 

SET$OCCURS:  PRCCEDURE(OCCUR ) J 
DECLARE  OCCUR  BYTE; 
SYMBOL(OCCURS )=OCCUR; 

END   SET$OCCURSJ 

GET^OCCURS:  PROCEDURE  BYTE; 
RETURN  SYMBOL  (OCCURS); 
END  GET$OCCURS; 


SET$IO$ADDRS:  PR 
SYMBOL$ADDR( 
SAVESADDR  = 

END  SET$IO$ADDRS 
/*   #   *   * 

DECLARE 

INT 

SCD 

PSTACKSIZE 

STATESTACK 

VALUE 

VARC 

ID$STACK 

IDiSTACK$PTR 

HOLD$LIT  (ACCUMi 

EOLD$SYM 

PENDING$LITERAL 

?ENDING$LIT$ID 

REDEF 

REDEF$ONE 

REDEEM  TWO 

TEMP$HOLD 

TEMP$TWO 

COMPILING 

SP 

MP 

MPP1 

NOLOOK 

(I, J, I) 

STATE 

VALUE$FIAG 

VALUE$LEVEL 

TRUNCiELAG 


ocedure; 
location)  = 
cur$sym; 


nextssym; 


PARSER  DECLARATIONS 


*/ 


LIT 

LIT 

LIT 
(PST 
(PST 
(51) 
(10) 
BYTE 
LEN$P$1 
ADDR 
BYTE 
ADDR 
BYTE 
ADDR 
ADDR 
ADDR 
ADDR 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 
BYTE 


'63' 

'66' 

'30' 

ACKSIZ 

ACKSIZ 


I 
)  BY 
ESS, 

INITI 
ESS, 


I 


f   /*  CODE  FOR  INITIALIZE  */ 
,  /*  CODE  TOR  SET  CODE  START 
,  /*  SIZE  OF  PARSE  STACKS*/ 
E)  BYTE,  /*  SAVED  STATES  */ 
E)  ADDRESS,  /*  TEMP  VALUES  */ 

BYTE,  /*TEMP  CHAR  STORE*/ 
ADDRESS     INITIAL  (0), 
NITIAL(0), 
TE, 

AL(FALSE), 

NITIAL  (FALSE), 


*/ 


ESS 
ESS 
ESS 
ESS 


INI 
INI 


INI 

INI 
INI 
INI 
INI 


TIAL 
TIAL 


TRUE) , 
(255), 


TIAL(TRUE), 

/*INDICIES 
TIALfSTARTS) 
TIAL(FALSE), 
TIAL(0), 
TIAL(TRUE); 


FOR  THE  PARSER*/ 


/*   *   *   *   PARSER  ROUTINES   *   * 


BYTE$OUT:  PR0CEDURE(0NE$3YTE ) ; 
/*  THIS  PROCEDURE  WRITES  ONE  BYTE 


*   */ 


OF  OUTPUT  ONTO  THE  DISK 
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IF  REQUIRED  THE  OUTPUT  BUFFER  IS  DUMPED  TO  THE  DISK  */ 

declare  onesbyte  byte? 

ie  (output$ptr:=output$ptr  +  1)>  output$snd  then 

do; 

call  write$output; 

output$ptr= .output$buff; 
end; 

output$chae=one$byte; 
end  eyte^out; 

strlngiout:  procedure  ( addr , count ) ; 

declare  (addr, i, count)  address,  (char  based  addr)  byte? 
DO  1=1  TO  count; 

CALL  BYTESOUT(CHAR); 

addr=addr+1j 
end; 
end  string^out; 

addr$out:  procedure( addr) ; 
declare  addr  address; 
call  byte$ out (low( addr) ); 

call  byte$out(high( addr)); 
END  addr$out; 

?ILL$STRING:  PROCEDURE! COUNT, CHAR) 5 

DECLARE  (I, COUNT)  ADDRESS,  CHAR  3YTEJ 
DO  1=1  TO  count; 

call  byte$out(char)j 
end; 

END  FILLiSTRING; 

START$INITIALIZE:  PROCEDURE (ADDR,CNT) ; 
DECLARE  (ADDR,CNT)  ADDRESS; 
CALL  BYTEOUT(INT); 
CALL  ADDR^OUT(ADDR); 
CALL  ADDDiOUT(CNT); 

END  start$initialize; 

build^symbol:  procedure (len  )  j 

declare  len  byte,  temp  address? 

temp=next$sym; 

if  (next$sym:=.symbol(len:=len+displacement)) 
>  maximemory  then  call  fatal$error( 'st' ) j 

call  fill  (temp, 0, len); 
END  build$symbcl; 

dup$iden$test:   procedure; 
declare   i    byte; 

if  redef^flag  then 
do; 

redef$flag  =  false; 

return; 
end; 
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ELSE 

if  file$desc$flag  then 
do; 

file£desc$flag  =  false? 

I  =  0; 

DO  WHILE  DUP$IDEN$ARRAY(I )  <>  0? 

IF  DUP$IDEN$ARRAY(I)  =  CUR^SYM  THEN 
DC- 
call  prlnt$error( 'di  '  )  j 
return; 
end; 
1=1+1; 

IF  I  >  23  THEN 

do; 

CALL  ?RlNT$ERROR(  'EF') ; 

return; 
end; 
end; 

dup*iden$array(i)  =  cursym; 
return; 
end; 

ELSE 

CALL  PRINT$ERROR( 'DI ' ) J 
END  DUP*IDEN$TEST! 

MATCH:  PROCEDURE  ADDRESS? 

/*  CHECKS  AN  IDENTIFIER  TO  SEE  IF  IT  13  IN  THE  SYMBOL 
TABLE.   IF  IT  IS  PRESENT,  CUR^SYM  IS  SET  FOR  ACCESS. 
OTHERWISE  A  NEW  ENTRY  IS  MADE  AND  THE  PRINT  NAME 
IS  ENTERED.   ALL  NAMES  ARE  TRUNCATED  TO  MAXSID^LEN*/ 
DECLARE  POINT  ADDRESS, 

COLLISION  BASED  POINT  ADDRESS, 
(HOLD, I)  byte; 

IF  VARC(0)>MAX$ID$LEN 

THEN  7ARC(0)  =  MAX$ID$LEN; 
/*  TRUNCATE  IF  REQUIRED  */ 
HOLD  =  0; 

do  1=1  to  varc(0);    /*  calculate  hash  code  */ 

hold=hold  +  varc ( i  ); 
end; 

point=free$storage  +  shl((hold  and  hash$mask ) , 1 ) j 
DO  forever; 

if  collision=0  then 
do; 

if  file$desc$7lag  then 
do; 

file$desc£flag  =  false; 
call  print$error( 'ui '); 
end; 

ELSE 

if  redef$flag  then 
do; 

REDEFiFLAG  =  FALSE; 
CALL  PRINT$ERROR(  'UI  ' )  J 


171 


end; 

ELSE 

do; 


end; 

cur^sym,collision=next^sym; 
call  build$symbol(varc(0) ); 
/*  load  print  name  */ 
symbol(p$length)=7arc(0); 
do  i  =  1  to  varco); 

symbol(start$name  +  i)=7arc(i); 
end; 
return  cur$symj 


cur$sym=collision; 

ie  (hold:=get$p$length)=varc(0)  teen 

do; 

i=i; 

do  while  symbol (start$name  +  i)=  varc(i); 

IE  (I  :=I+l)>HOLD  THEN 

do; 

call  dup$iden$test; 
return  (cur$sym:=c0llisi0n) ; 
end; 
end; 
end; 
end; 

point=collision; 
end; 
end  match; 

allocate:  procedure( bytes $req )  address; 

/*  this  routine  controls  the  allocation  of  space 
in  the  memory  0?  the  interpreter.  */ 

declare  (hold,bytes$req)  address; 
hold=next$ available  j 

ie  (nextiavailable:=next$availa5le  +  3ytes$req) 
>max$int$mem 
then  call  eatal$err0r ( 'mo ' ) j 
return  hold; 
END  allocate; 

DIGIT:  PROCEDURE  (CHAR)  BYTE; 
DECLARE  CHAR  BYTE; 
RETURN  (CHAR  <=  '9')  AND  (CHAR  >=  '0'); 

END  digit; 

set$redef:  procedure ( old, new ) j 
declare  (old, new)  address; 

redee$one=old; 

redee$tw0=new; 

redee=true; 
end  set$redee; 

s3t$cur$sym:  procedure; 
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CUR£SYM=ID£STACK(ID£STACK$PTR)  J 
END  SET$CUR$SYM; 

STACK$LEVEL:  PROCEDURE  BYTE; 

CALL  set$cup$sym; 
return  get$levelj 
end  stack$level; 

load$level:  procedure; 
declare  hold  address? 

load$redef$addr:  procedure; 

cur$sym=redef$one; 

hold=get$ address; 
end  load$redef$addr; 

ip  id$stack(0)  <>  0  then 
do; 

if  value(sp-2)=0  then 
do; 

call  set$cur$sym; 
hold=get$s$length  +  getsaddress; 
end; 

else  do; 

if  file$sec$end  then 
do; 
if  idistack(idistack$ptr)  <>  redef$one 

THEN 

do; 

CALL  PRINT$ERR0R(  'Rl')J 

redef$one=id$staci(id$stack$?tr) ; 

end; 
end; 
call  load$redef$addr; 
end; 

if  (id$stack$?tr:=id$stac£$ptr+1)>9  then 
do; 

call  print$error( 'el'); 

IDiSTACK$PTR=9; 
END; 

end; 

else  hold=next$av»ailable; 

id$stack' id$stack$ptr)=value(mpp1 ) ; 

call  set$cur$sym; 

if  (getilevel  =  1)  and  (not  file$sec$end )  then 

call  set$addr2(sa7e$addr)j 
call  set$addrsss(hold); 

END  LOADiLSVELJ 

rsdef$or lvalue:  procedure; 
declare  hold  address, 

(deck, j.sign, char)  byte? 
if  redef  then 
do; 
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if  redef$two=cur$sym  then 
do; 

hold=get$s$length; 
cur$sym=redef$one; 
IP  hold>get$s$length  then 
do; 

CALL  PRlNT$ERROR( 'R2')i 

hold=get$s$length; 
cur$sym=redef$two; 
call  set$s$length(hold)5 
end; 
end; 
end; 
else  i?  pending$literal=0  then  return; 
if  (pending$lit$idoid$stack$ptr)  or  value$flag 
then  return; 

if  pending$literal  <>  0  then 

call  st art$ i niti al ize(get$ address, hold :=get$ si  length); 
if  pending$literal>2  then 
do; 

if  pending$literal=3  then  cear='0'j 
else  if  pending$literal=4  then  char='  '; 
else  if  pending$literal  =  5  then  char  =  quote; 
call  fill$string(hold,char)  ; 
end; 
else  if  pending$literal  =  2  then 
do; 
if  hold  <=  hold$lit(0)  then 

CALL   STRING$0UT( .HOLD$LIT(l) ,HOLD); 
ELSE  do; 

CALL   STRING$0UT( .HOLD^LIT(l) ,HOLD$LIT(0) ); 
CALL    FILL$STRING(HOLD    -   EOLD$LIT ( 0 ) , '    '); 
END; 

end; 
else  if  pending$literal=1  then 
do; 

/*  the  number  hanbeler  */ 
dfclare  (dec,minus$sign,i , j ,lit$dec , n$length , 
num$before,num$ after,  type)  byte, 

ZONE  LIT  '10H'J 

IF((TYPE:=GET$TYPE)<16)  OR  (TYPE>21)  THEN 
CALL  PRlNT$ERROR(  'NV'); 

n$length=get$s$length; 

dec=gst$decimal; 

minus$sign=false; 

IF  HOLD$LIT(l)  =  '-'  THEN 

do; 

minus$sign=true; 
j=i; 

end; 

ELSE  IF  HOLD$LIT(l)  =  '+'  THEN  J=i; 

ELSE  J=0J 
LIT$DEC=0J 
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do  1=1  to  hold$lit(0); 

if  hold$lit(i)='.'  thin  lit$dsc=l; 
end; 

if  eold$lit(0)  <>  0  teem 
do; 

if  lit$dec=0  then 
do; 

num$before=hold$lit(0 )-j; 
num$after=0j 
end; 
else  do; 

num$before=lit$dec  -j-i; 
num$after=hold$lit(0)  -  litidec; 
end; 
end; 
else  if  hold$lit(0)  =  0  then 
do; 

num$before  =  0j 
num$ after  =  0j 

LIT$DEC  =  0; 

end; 
if  (i:=n$length  -  dec )<num$before  then 
call  print$error('sl'); 

if  i>nom$before  then 
do; 

i=i-num$before; 
IF  minus$sign  then 

do; 

i-i-i; 

call  btte$out('0'  +  zone); 

end; 

CALL   FILL$STRING(I t  '0'); 

end; 
else  if  minus$sign  then  holdilit ( j+l ) 

=hold$lit(j+i)+zone; 
call  strlng$out( .hold$lit( 1 )+j , num$3sf0re ) j 
if  num^after  >  dec  then  num^after  =  dec? 
call  string$out( .hold$lit(l)  +  litsdec,  numiaftsr 
if  (i:=dec  -  num$after)<>0  then 

call  fill$string(i, '0')j 

END; 
IF  NOT  VALUE^FLAG  THEN  PENDING$LITERAL=0 ; 

END  redef$or$valde; 

REDUCE$STACK:  PROCEDURE; 

DECLARE  HOLD$LENGTH  ADDRESS; 

CALL  set$cur$sym; 
call  redff$or^value; 
hold$length=get$s$length; 
if  get$ty?e  >  128  teen 
do; 

hold$length=hold£lengte  *  get$occurs; 
end; 
id$stack$ptr=id$stack$ptr  -  i; 
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CALL  set$cur$sym; 

CALL  SET$S$LENGTH(GET$5$LENGTH  +  HOLD$ LENGTH ) 5 

CALL  SET$TYPE(GROUP)J 

END  reduce$stack; 

END$OF$RECORD:  PROCEDURE; 

DO  WHILE  IDSSTAC!C$?TR  O  0J 

CALL  set$cur$sym; 

CALL  redef$or$value; 

id$stack(id$stack£ptk)=0; 

id$stack$ptr=id$stac5$ptr  -  1? 
end; 
CALL  set$cur$sym; 

CALL  REDEF$ORiVALUE; 

ID$STACK(0)=0; 

TEMPiHOLD= ALLOC ATE(TEMP$TWO:=GET$S$LENGTH); 

END  end$of$record; 

CONVERT$INTEGER:  PROCEDURE; 
DECLARE  INTEGER  ADDRESS; 
INTEGER=0; 
DO  I  =  1  TC  VARC(0) ? 

IE  NOT  DIGIT(VARC(I ) )  THEN  CALL  PRINT$SRROR(  'NN  ' ) J 
/*  ERROR  RECOVERY  FOR  AN  '0'  WHICH  SHOULD 
HAVE  BEEN  A  ZERO— '0'  */ 
I?  (VARC(I)  =  '0')  THEN  VAPC(I)  =  '0'j 

integer=shl(integer,3)+shl(intsger,l)+(varc(i)-'0') 
end; 

value(sp)=integer; 
end  convert$integer; 

ori value:  procedure ( ptr tattrib) ; 

declare  ptr  byte,  attrib  address? 

value(ptr)=value(ptr)  or  attrib; 
END  or$value; 

BUILD$FCB:  PROCEDURE; 

DECLARE  TEMP  ADDRESS; 

DECLARE  BUFFER(ll)  BYTE,  (CHAR,  I,  J)  BYTE? 

CALL  FILL( .BUFFER,'  ',11); 

J, 1=0; 

DO  WHILE  (J  <  11)  AND  [I<   VARC(0))J 

IF  (CHAR:=VARC(I:  =  I*l))  =  '.  '  THEM  J=3J 
ELSE  do; 

buffer ( j) =char; 
j=j+i; 
end; 

end; 

call  set$ addr2( temp :  =  all0cate( 165)  )j 

call  start$initialize(temp,37); 

call  byte$cut(0); 

call  string$out( .buffer, 11); 

call  fill$string(25,0); 

call  0r$value(sp-1,1)» 
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end  build^fcb; 

set$sign:  procedure (numb) j 

declare  numb  byte; 

ip  get$ty?e=17  then  call  s et^type ( value(s p )  +  numb); 
else  call  printierror(  'sg '  )  j 

if  value(sp)<>0  then  call  set$s$length(gbt$s$length  +  1); 
end  set$sign; 

num$trunc:  procedure? 

declare  i        byte, 

J  BYTE, 

TRUNC$TYPE  BYTE, 

TRUNC$ZERO  BYTE, 

SIGN$FLAG  BYTE, 

DEC$FLAG  BYTE; 

TRUNC$2ERO  =  TRUE; 
SIGN$FLAG  =  FALSE; 
DEC*FLAG  =  FALSE; 
HOLD$LIT(0)  =  0; 
J  =  i; 
I  =  0; 

if  ( (trunc$type:=get$type)=16)  or  (trunc^ type=17)  or 
(trunc$typi  =  21)  then 
do  while  j  <=  varc(0); 
if  (varc(j)  <>  '+')  and  (varc(j)  <>  '-')  then 
do; 

if  (varc(j)='0')  and  truncszero  then  j=jj 
else  if  {(varc(j)  >=  '0')  and  (vapc(j) 

<='9'))  OR 

(7arc(j)  ■  '.')  then 
do; 

if  dec$flag  and  (varc(j)  =  '.')  then 
call  print$error( 'md'); 

ELS  F  DO  * 

eold$lit(hold$lit(0) :=hold$lit (0 ) +1 ) 
=varc(j); 

IF  VARC(J)  O  '0'  THEN  TRUNC$ZERO  =  FALSE; 
IF  VARC(J)  =  '.'  THEN  DEC$FLAG  =  TRUE; 
I  =  I  +  U 

end; 
end; 

ELSE  IF  ((VARC(J)  <  '0')  OR  (VARC^J)  >  '9'))  AND 

uapc(j)  <>  '.*)  then  call  pri  nt$error(  '  nn  ' )  ; 
end; 

ELSE  IF  SIGN$FLAG  THEN  CALL  PRINT$ERROR (  'MS  ' ) ; 

else  if  (vaf.c(j)  =  '+')  or  (varc(j)  =  '-')  then 
do; 

if  trunc$type  =  16  then  call  print$error ( 'sg  '  )  j 

ELSE    DO  * 

HOLD$LIT(HOLD$LIT(0) :=EOLD$LIT( 0 ) +1 ) =VAHC ( J ) ; 
SIGN$FLAG   =    TRUE; 
I    =    I+U 
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end; 
end; 
j  =  J  +  1; 
end;/*  do  while  loop  */ 

HOLD$LIT(0)  =  15 

IE  ((HOLD$LIT(0)  =  1)  AND  ( (HOLD$LIT(l )  = 
(HOLD$LIT(l)  =  '-')))  OR  (HOLD$LIT(0) 

do; 

hold$lit(0)  =  0j 

HOLD$LIT(l)  =  0; 

end; 
end  numstrunc; 


'*')  OR 
=  '0')  THEN 


PIC$ANALIZER:  PROCEDURE; 

DECLARE    /*  WORK  AREAS 

AND  VARIABLES 

FLAG        BYTE, 

FIRST       BYTE, 

COUNT       ADDRESS, 

BUFFER  (31  )  BYTE, 

SAVE        BYTE, 

REPITITIONS  ADDRESS, 

J           ADDRESS  , 

DEC^COUNT   BYTE, 

CHAR        BYTE, 

I           BYTE, 

TEMP        ADDRESS, 

TYPE        BYTE, 

DEC$FLAG     BYTE, 

K           BYTE, 

/*  *  *  MASKS  *  *  */ 

ALPHA    LIT  'l', 

A$EDIT    LIT  '2', 

A$N      LIT  '4', 

EDIT     LIT  '8', 

NUM      LIT  '16', 

NUM$EDIT  LIT  '32', 

DEC      LIT  '64', 

SIGN     LIT  '128', 

NUMiMASK        LIT 

'10101111B', 

NUM$ED$MASK     LIT 

'10000101B', 

S$NUM$MASK      LIT 

'00101111B', 

ALPHA$MASK     LIT 

'11111110B', 

A$E$MASK        LIT 

'11111100B', 

A$N$MASK        LIT 

'11101010B'. 

A$N$E$MASK     LIT 

'11100000B', 

/*  TYPES  */ 

NETYPE  LIT  '80', 

NTYPE   LIT  '16', 

SNTYPE  LIT  '17', 

ATYPE   LIT  '8', 

AETYPE  LIT  '72', 

*/ 
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ANTYPE  LIT  '9', 
ANETYPE  LIT  '73'j 

inc$count:  procedure! switch) j 
declare  switce  byte; 
flag=flag  or  switcej 

ie  ( count :=count  +  1)  <  31  teen  3u?feh(count) 
=  char; 

END  INCiCCUNTJ 

CHECK:  PROCEDURE  (MASK)  BYTE; 

/*  THIS  ROUTINE  CHECKS  A  MASK  AGINST  THE 
FLAG  BYTE  AND  RETURNS  TRUE  ID  THE  FLAG 
HAD  NO  BITS  IN  COMMON  WITH  THE  MASK  */ 
DECLARE  MASK  BYTE; 
RETURN  NOT  (  (FLAG  AND  MASK)  <>  3); 

END  check; 

pic^allocate:  ?rocedure( amt)  address; 
declare  amt  address? 
if  (max$intsmem:=max$int$mem  -  amt) 
<  next$available 
then  call  fatal^error  ('mo'); 
return  max$int*mem; 
end  pic$allocatej 

/*  procedure  execution  starts  here  */ 

cur^sym  -  hold$sym; 

if  (get$lsvel  =  value$level)  then  value$flag  =  false; 

dec$flag  =  false; 

count, flag  ,dec$coun t=0; 

/*  check  for  excessive  length  */ 

if  varc(0)  >  30  then 

do; 

call  print$error(  'pc')  j 
return; 
end; 

/*  set  flag  bits  and  count  length  */ 
i  =i; 
do  while  k=7arc(0)  ; 

if  (char:=varc(i  ))  =  'a'  then  call  inc$ccunt ( alpha ) j 
else  if  char  = 'b  '  teen  call  inc$ccumt( a*edit ) j 
else  if  char  =  '9'  then  call  incsccunt ( num)  ; 
else  if  char  = 'x '  then  call  inc$count( a$n ) j 
else  if  (chart's')  and  (cgunt=0)  then 

flag=flag  or  sign; 
else  if  (char  =  '/')  and  ( dec$count=0 )  thsn 
do; 

dec$count  =  count; 
dec$flag  =  true; 
end; 
else  if(char='/')  or  (char='2')  then 
call  inc$counti(edit); 
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ELSE 


ELSE 


(CHAR-'*') 

(CHAR='$') 


THEN 


ELSE 


ELSE 


IE 

(char='z')  or  (cha?=v)  or 
(char='+')  or  (char='-')  or 
call  inc$count( num$edit); 
ie  (char='.')  and  ( dec$count=0  ) 

do; 

call  inc$count(num$edit); 

dec$count=count; 

dec$flag  =  true; 

end; 

IE  ((CHAR='C')  AND  (7AEC (1+1 )='R'))  OR 
((CHAR='D')  AND  ( VARC ( 1  +  1 )  =  'B  ' )  )  THEN 

do; 

call  inc$count(num$edit) ; 

cear=varc(i:=i+1); 

call  inc$count(num$edit); 

end; 

AND  (COUNTO0)  THEN 


OR 
THEN 


IE  (CHAR='(  ' 

do; 

save=varc(i-1) ; 

repititions=0; 

do  vhile(char:=varc(i :=i+1 ))<>') '; 

repititi0ns=shl(repititi0ns,3)  + 

shl(repititicns.l)  +(char  -'0'); 
end; 
char=save; 

DO  J=l  TO  REPITITIONS-i; 
CALL  INC$COUNT(0); 

end; 
end; 
else  do; 

CALL  PRlNT$ERROR( 'PC'); 

return; 
end; 
1=1+1 ; 

end;  /*  end  oe  do  while  i<=  varc 
/*  at  this  point  tee  type  can  be 
ip    not  check(num$edit)  then 
do; 

ie  check(num£ed$mask)  then  type=netype; 
end; 

check(num$mask)  then  type=ntype; 
check(snum$r*ask)  then  type=snty?e; 
checs(alpha$mask)  then  type  =  atype; 
check(a$s$mask)  then  type  =  astypej 
check(a$n$mask)  then  ty?e=antype; 
check(a$n$e$mask)  then  type=anstypej 
if  ty?e=0  then  call  print$errcr ( 'pc ' ) ? 
ELSE  do; 

ie  (get$type=128)  then  call  sbt$typ5(128+type) j 
else  call  set^type ( type ) j 
call  set<slength(count  *  g-et$s  ^length)  j 
if  (type  and  64)  <>  0  then 
do; 


*/ 

DETERMINED 


*/ 


ELSE 
ELSE 
ELSE 
ELSE 
ELSE 
ELSE 


IF 
IF 
IF 
IF 
IF 
IF 
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call  ssti?  addr2(  temp  :  =  pi  (^allocate  (count)  ); 
call  start$initialize(temp, count) j 
call  string* out (.buffer  +  ltcount); 
end; 
if  (discount  <>  0)  or  dec$flag  then 
do; 
if  (count  -  dec$count)  >  19  then 

call  print$err0r( 'dc'); 
call  set$decimal(count  -  dec^count); 
end; 
end; 

if  (not  trunc$flag)  and  ((type  =  16)  or  (type  =  17))  then 
do; 

do  k  =  0  to  hold$lit(0); 
varc(k)  =  hold$lit(k)j 
end; 

call  num$trunc; 
trunc$flag  =  true; 
end; 
end  pic$analizer; 

set$file$attri3:  procedure; 

declare  temp  address,  type  byte; 
if  cur$symovalue(mppl)  then 
do; 

temp=cur*sym; 

cur$sym=value(mpp1); 

symbol$addr(rel£id)=temp; 
end; 

if  not  (temp:=value(sp-1) )  then  call  print$error  ('nf')j 
ELSE  do; 

IF  TEMP=1  THEN  TYPS=SECUENTI AL ; 

ELSE  IF  TEMP=15  THEN  TYPS=RANDOM; 

ELSE  IF  (TEMP=5)  OR  (TEMP=13)  TEEN 

TYPE  =  seq$relative; 
ELSE  do; 

call  print$error('ia'); 
type=i; 
end; 
end; 
call  set$ty?e(type) ; 
end  set$file$attrib; 

load$ literal:  procedure (litione) ; 
declare  i       byte, 
lit$one   byte, 
lit$type  byte; 

lit^type  =  get^type; 

if  litstype  <>  0  then  valuesflag  =  false,* 

else  do; 

value$flag  =  true; 

value$level  =  gethevelj 

end; 
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if  pending$literal  <>  0  then  call  printserrcr  ('le')j 
else  if  (lit$0ne  =  0)  op.  (lit^type  =  0)  then 

do; 

do  i  =  0  to  varc(0); 

HOLD$LIT(I )  =  VARC(I); 

end; 

if  (lit$one  =  1)  and  (litstype  =  0)  tusn 

trunc$flag  =  false? 
end; 
else  if  (litione  =  1 )  and  ((lititype  =  16)  or 

(lititype  =  1?)  of  (lit$type  =  21))  then 
call  num$trunc; 
else  if  (lit$one  =  1)  and  ((lit$type  <>  16)  or 

(lit$type  <>  17)  of.  (lit$ty?e  <>  21))  and 
(lit$type  <>  0)  then 
do; 

call  print$error( 'lv')j 
do  i  =  0  to  varc(0) ; 

hold$lit(i)  =  varc(i); 
end; 

pending$literal  =  2; 
end; 
end  load$literal; 

redef$test:  procedure; 

declare  save^rsdef  byte, 

savs$redef$one  address, 

save$redef$two  address; 
save$redef$one  =  redsficne; 
save$redef$tvo  =  redef^two? 
redef$one  =  cur$sym; 
call  set$cur$sym; 
redet$two  =  cur^sym; 
save$redef  =  redef; 
redef  =  true? 
CALL  redef$or$v«lue; 

ID$STACK(ID$STACK$PTR)    =   0; 
IDiSTACKSPTR    =    IDiSTACK^PTR    -    15 
REDEF$ONE    =    S AVEiREDEF$ONEJ 
REDEF$TWO   =    SAVE$REDEF$TWOJ 
REDEF    =   SAVE$REDEF; 

END  redef$test; 

check$lvl$files:     procedure; 
declare  newslevsl    bytej 
hold$sym,cur$sy*=valuf(m?-l) ; 
call  set$level(new$level:=value(s1p-2)  ); 

if  new$level  =  1  then 
do; 

if  id$stack(0)  <>  0  then 
do; 
do  while  stack$level  >  1! 

call  reduce$stack; 
end; 
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DO  WHILE  ID$STACK!>?TR  <>  0; 

CALL  set$cur$sym; 
CALL  redef$or$value; 

ID$STACK(IP$STACK$PTR)  =  0J 
ID$STACK$PTR  =  ID$STACK$PTR  -  lj 

end; 

CUR$SYM  =  hold$sym; 

call  set$redef(id$stack(0) ,v*lue(mp-1) )j 
value(mp)  =  l;/*  set  redefine  flag  */ 
end; 
end; 
else  do  while  stacksle7el  >=  new$le7el; 
call  reduce$stackj 
end; 
end  check$lvl$files; 

check$lvl$work:  procedure; 

declare  new$level     byte, 

SAVEiSYMUVL  BYTE, 

STACK$REDUCED  BYTE, 

SA7E$REDEF  BYTE, 

SAVE$SYM  ADDRESS; 

SET$VALUE$CLAUSE:    PROCEDURE? 

SAVE^REDFF    =   REDEF? 

REDEF   =   FALSE; 

CALL  SET$CUR$SYMJ 

CALL    REDEF$0R*7ALUE; 

REDEF   =   SAVE^REDEF; 

CURiSYM  =  hold^sym; 
end  set$value$ clause? 

trunc$flag  =  true; 

stacks reduced  =  false; 

holdisym,cur$s ym= value (mp-1); 

call  setilevel(new$level:=value(m?-2) ) ; 

if  newuevel  =  1  then 

do; 

do  while  stack^level  >  1  and  id$stack(  id$st».ck$pt7.)  <>0j 

save$sym,cur$sym=id$stack(id$stacx$ptr  -  1); 

save$syp$l7l  =  get$ls7el; 

if  save$sym$lvl  =  stack$level  then 

do; 

CUR$SYM  =  save$sym» 

call  redef$test; 

end; 

else  if  stack$level  >  1  then 
do; 

call  reduce$stack; 

if  value$flag  and  (valus$le7el  =  stackilevel)  then 
do; 

value$flag  =  false; 
call  set$7alue^clause; 
end; 
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end; 

end;/*  do  while  loop  */ 

if  stack^level  =  1  and  id$stac£$ptr  o  0  then 

do; 

cur$sym  =  id$stack(id$stack$ptr  -  1); 

CALL  redef$test; 

end; 

if  value(mp)  =  0  and  id^stack ( id$stack$ptr )  <>  0  then 

do; 

call  end$of$record; 

redef  =  false; 

end; 

if  (value(mp)  =  1)  and  (id$stack ( id$stacx$?tr )  =  pedef$0ne) 

then  call  set$value$clause; 
CUR$SYM  =  hold$sym; 
end; 
else  if  stackilevel  >=  newilevel  then 

do; 
if  (stack$level  =  nev$level)  and  (value(mp)  =  1)  and 

(id$stack( id$stack$ptr)  =  redef$0ne)  then 

call  set$value$clause; 
do  while  not  stack$reduced; 
save$sym,cur$sym=id$stack(id$stack$?tr  -  1); 
save$sym$l7l  =  set$level; 
if  save$sym$lvl  =  stack$l2vel  then 
do; 

cur$sym  =  save$sym; 
call  redef$test; 
end; 

else  if  (stackilevel  >=  ne*$level)  and 
(value (mp)  =  0)  then 
do; 

do  while  stack$level  >=  new$levelj 
CALL  reducs$stack; 

if  valueiflag-  and  (  v  alue<>level=stack$levsl  ) 
and  (value$level  =  new$le7el)  then 
do; 

value^flao-  =  false; 
call  set$value$clause» 
end; 

end?/*  do  while  loop  */ 
stack ^reduced  =  tf.tje? 
end; 
else  if  (stack5level  >=  new$level)  and 
(value (mp)  =  1)  then 
do; 

do  while  stack^level  >  new$levelj 
call  reduce$st»ckj 
if  value$flag  and  (value$level  =  stackslevel) 

THEN  DO; 

value*flag  =  false; 
call  set$value$clauss; 
end; 
end;/*  do  while  loop  */ 
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stack$reduced  =  true; 
end; 
end;/*  do  while  loop  */ 
end; 

cur$sym  =  hold^sym; 
end  check$lvl$work; 

CODE$GEN:  procedure(production); 
declare  production  byte, 
lit$type   3YTe; 
if  print$prod  then 
do; 

call  cflf; 

call  printghar(pound); 
call  print$n0mber( production ) j 
end; 

DO  CASE  production; 

/*  productions*/ 

/*  case  0  not  used     */ 

i 

/*  1  <program>  ::=  <id-div>  <z-div>  <b-div>  procedure  */ 
do; 
compiling=false; 

DI SPLAY (DISPLAY (0)+l  )='$'; 
CALL  PRINT( .DISPLAY(l) ); 

end; 

/*  2  <id-div>  ::=  identification  division  .  program-id  .*/ 
/*  2   <comment>  .  <auth>  <date>  <ssc>  */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*  3  <AUTH>  ::=  AUTHOR  .  <COMMENT>  .       */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*  4    \!  <EMPTY>  */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*  5  <DATE>  ::=  DATE-WRITTEN  .  <COMMENT>  .     */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*  6    \!  <EMPTY>         */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*  7  <SEC>  ::=  SECURITY  .  <COMMENT>  .      */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*  8    \!  <EMPTY>         */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*  9  <COMMENT>  : :=  <INPUT>         */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*10     \!  <COMMENT>  <INPUT>       */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*11  <E-DIV>  : :=  ENVIRONMENT  DIVISION  .  CONFIGURATION  */ 
/*11     SECTION  .  <SRC-OBJ>  <I-0>     */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*12  <SRC-OBJ>  ::=  SOURCE-COMPUTER  .  <COMMENT>  <DT?UG>  .*/ 
/*12      OBJECT-COMPUTER  .  <COMMENT>  .    */ 

J  /*  NO  ACTION  REQUIRED  */ 
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/*13  <DEBUG>  ::=  DEBUGGING  MOPE        */ 

debugging=true;  /*  SETS  a  scanner  toggle  */ 

/*14     \!  <EMPTY>  */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*15  <I-0>  ::=  INPUT-OUTPUT  SECTION  .  FILE-CONTROL  .   */ 
/*15     <FILE-CONTROL-LIST>  <IC>      */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*16    \!  <EMPTY>  */ 

j  /*  no  action  required  */ 
/*17  <file-control-list>  : :=  <file-control-entry>  */ 

j  /*  no  action  required  */ 
/*18  \!  <file-control-list>      */ 

/*18  <file-control-entry>    */ 

j  /*  no  action  required  */ 
/*19  <file-control-entry>  ::=  select  <id> 

<attribute-list>  .  */ 

call  set$file$attribj 
/*20  <attri3ute-list>  : :=  <one-attrib>    */ 

j  /*  no  action  required  */ 
/*21     \!  <atthibute-list>  <one-attrib>  */ 

value(mp)=value(sp)  or  value (mp); 
/*22  <one-attrib>  : :=  organization  <org-type>   */ 

value(mp)=value(sp); 
/*23    \!  access  <acc-type>  <relati7e>  */ 

value(mp)=value(mpp1)  or  value(sp); 
/*24    \!  assign  <input>     */ 

call  buildSfcb; 
/*25  <org-type>  : :=  sequential     */ 

;  /*  no  action  required  -  default  */ 
/*26   \!  relative      */ 

call  or$value(sp,4); 
/*27  <acc-type>  ::=  sequential  */ 

j  /*  no  action  required  -  default  */ 

7*28     \!  RANDOM         */ 

CALL  0R$VALUE(SP,2)J 
/*29  <RELATIVE>  ::=  RELATIVE  <ID>       */ 

CALL  OR$VALUE(MP,8); 
/*30     \!  <EMPTY>         */ 

;  /*  NO  ACTION  REQUIRED  -  DEFAULT  */ 
/*31  <IC>  ::=  I-O-CONTROL  .  <SAMS-LIST>      */ 

1 

/*32    \!  <EMPTY>         */ 

/*33  <SAME-LIST>  ::=  <S AME-ELEMENT>       */ 

/*34      \!  <SAME-LIST>  <SAME-ELEMENT>    */ 

» 
/*35  <SAME-ELEMENT>  :  :=  SAME  <ID-ST?.ING>  .     */ 

/*36  <ID-STRING>  ::=  <ID>         */ 

/*37      \l  <ID-STRING>  <ID>      */ 
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/*38  <D-DIV>  :  :=  DATA  DIVISION  .  <FILS-SECTION>  <WORK>  •/ 
/*38     <LINK>  */ 

J  /*  NO  ACTION  REQUIRED  */ 
/*39  <FILE-SECTION>  ::=  FILE  SECTION  .  <FILE-LIST>   */ 

FILE$SEC$END  =  TRUE; 
/*40      \!  <EMPTY>        */ 

file$sec$end=true; 

/*41  <file-list>  ::=  <files>      */ 
j  /*  no  action  required  */ 

/*42      \f  <FILE-LIST>  <FILES>      */ 

;  /*  no  action  required  */ 
/*43  <files>  :  :=  fd  <id>  <?ile-control>  .   */ 
/*43   <record-description>    */ 
do; 

do  while  stack$level  >  1? 
call  reduce$stackj 
end; 

call  end$cf$record; 
redef=false; 
end; 
/*44  <file-control>  ::=  <file-list>  */ 

CALL  SET^IOiADDRS? 
/*45      \!  <EMPTY>        */ 

call  set$io$addrsj 
/*46  <file-list>  ::=  <file-element>     */ 

j  /*  no  action  required  */ 
/*47    \!  <file-list>  <file-element>   */ 

j  /*  no  action  required  */ 
/*48  <file-5lement>  : :=  block  <integer>  records   */ 

j  /*  no  action  required  -  files  never  blocked  */ 
/*49    \!  record  <rec-count>   */ 

call  set$slength(value(sp) ); 
/*50    \l  label  records  standard   */ 

j  /*  no  action  required  */ 
/*51    \!  label  records  omitted   */ 

;  /*  no  action  required  */ 
/*52    \!  value  of  <id-string>   */ 

j  /*  no  action  required  */ 
/*53  <rec-count>  : :=  <integer>      */ 

j  /*  no  action  required  -  value(sp)  correct  */ 
/*54    \!  <integer>  to  <integer>   */ 

do; 

value(mp)=value(sp);  /*  variable  length  */ 

call  set$type(4);  /*  set  to  variable  */ 

end; 

/*55  <work>  ::=  working-storage  section  .    */ 
/*55   <record-description>     */ 

do; 

do  while  stack^level  >  1j 
cur$sym  =  id$stacx(id$stack$ptr  -  1); 
if  get$level  =  stack$level  then 
CALL  redef$test; 

ELSE  IF  STACK$LEVSL  >  1  THEN 
CALL  REDUCE$STACKJ 
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end; 

ip  stack$level  =  1  and  id$stack$ptr  <>  0  then 
do; 

curisym  =  id$stack(id$stack$?tr  -  1); 
if  redef  then  call  redef^test; 
end; 

call  end$of$record; 
end; 

/*56    \!  <EMPTY>  */ 

;  /*  NO  action  required  */ 

/*57  <LINK>  ::=  LINKAGE  SECTION  .  <RECORD-DESCR IPTION>  */ 

CALL    PRINT$ERROR( 'NI')  ;    /*    INTER    PROG    COttM    */ 
/*58        \!    <EMPTY>  */ 

j  /*  no  action  required  */ 
/*59  <record-description>  : :=  <level-entry>   */ 

;  /*  no  action  required  */ 
/*60     \!  <record-description>  */ 
/*60     <level-entry>   */ 

;  /*  no  action  required  */ 

/*61  <level-entry>  : :=  <intege?>  <d«?a-id>  <redefines>  */ 
/*61     <data-type>  .     */ 

do; 
call  load$level? 

if  (pendingsliteral  <>  0)  and  (not  value$?lag)  then 
pending$lit$id  =  id$stack$pt?.j 

end; 
/*62  <data-id>  ::=  <id>       */ 

j  /*  no  action  required  */ 

/*63     \!  FILLER         */ 

do; 

CUR$SYMt  VALUE(SP)=NEXTiSYM; 

call  3uild$5ymbol(0); 
end; 

/*64  <redefines>  ::=  redefines  <id>     */ 
do; 

call  set$redef(7alue(sp) , value; sp-2 ) ) ; 

value(mp)=1j  /*  set  redefine  flag  on  */ 

if  not  file$sec$end  then 

call  print$error(  '33')  ; 

call  check$lvl$work> 
end; 

/*65      \!  <E!*PTY>         */ 

do; 

if  not  file$sec$end  then 
call  check^lvl^files; 
else  call  che ck$lvl$*ork j 
end; 

/*66  <data-type>  ::=  <peop-list>     */ 
;  /*  no  action  required  */ 

/*67      \!  <E^PTY>         */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*68  <PROP-LIST>  ::=  <DATA-ELEMENT>       */ 

;  /*  NO  ACTION  REQUIRED  */ 
/*69  \!    <PROP-LIST>    <DATA-3L3MENT>         */ 
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/*71 

CALL 
/*72 

;  /* 

/*73 

CALL 
/*74 

CALL 
/*75 

do; 

CALL 
CALL 

snd; 

/*76 

;  /* 

/*77 


<INPUT> 
*/ 


J  /*  NO  ACTION  REQUIRE!}  */ 
/*70  <DATA-ELEfFNT>  :  :=  PIC 
CALL  PICiANALIZER; 

\!  USAGE  COMP 
SET$TYPE(COMP); 

\!  USAGE  DISPLAY      */ 
NC  ACTION  REQUIRED  -  DEFAULT  */ 

\!  SIGN  LEADING  <SEPARATE> 
SET$SIGN(17); 

\!  SIGN  TRAILING  <SEPARATE> 
SET$SIGN(13); 

\!  OCCURS  <INTEGER> 


*/ 


*/ 


*/ 


0R$TYPE(123)J 
SET$OCCURS(VALUE(SP)) 


\!    SYNC    <DIRECTION> 
NO    ACTION   REQUIRED   -   EYTE 
\!    VALUE    <LITERAL> 


*/ 

MACHINE    */ 
*/ 


do; 

ie  not  file$sec$end  then 
do; 

call  print$error(  've')j 
pending$literal=0; 
end; 
end; 

/*78  <direction>  ::=  left 
j  /*  no  action  required  */ 

/*79      \!  RIGHT        */ 
ACTION  REQUIRED  */ 
\!  <Ef*PTY>      *■/ 
ACTION  REQUIRED  */ 
:=  SEPARATE 


*/ 


NO 


NO 


;  /* 

/*80 

;  /* 

/*81  <SEPARATE> 

VALUE(SP)=2; 
/*82     \!  <EMPTY>        */ 

j  /*  no  action  required  */ 
/*s3  <literal>  :  :=  <input> 
do; 
if  ( (lit$type:=get$type)  <>  16) 

(lit^type  <>  17)  and  (lit$ty?e 

do; 

call  print^error('nv'); 

call  load$literal(0); 

pending$lit1ral  =  2; 

END; 

else  do; 

CALL  LOAD$LITERAL(l) ; 

pending$lit?ral  =  1j 
end; 
end; 

/*84     \!  <LIT>  */ 

do; 
call  load$literal(0) ; 
pending$literal=2; 


*/ 


*/ 

AND 
<>  21) 


THEN 
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end; 

/*85     \!  ZERC         */ 

PENDING$LITERAL=3; 
/*86     \!  SPACE         */ 

PENDING$LITERAL=4J 
/*87     \!  QUOTE         */ 

pending$literal=5; 

/*88  <integer>  : :=  <input>      */ 
call  convert$integer; 

/*89  <ID>  ::=  <I.MPUT>         */ 
VALUE(SP)=MATCHJ  /*  STORE  SYMBOL  TABLE  POINTERS  */ 


END?  /*  END  OF  CASE  STATEMENT  */ 

END  code$gen; 

GETIN1:  PROCEDURE  BYTE; 

RETURN  INDEX1 (STATS); 
END  GETINIJ 

GETIN2:  PROCEDURE  BYTE; 

RETURN  INDEX2(STATE); 
END  GETIN2J 

INCSP:  PROCEDURE? 

SP=SP  +  1; 

IF  SP  >=  PSTACKSIZE  THEN  CALL  FATAL$ERROR (  'SO  '  ) ; 

VALUE(SP)=0;  /*  CLEAR  VALUE  STACK  */ 
END  INCSP; 


DUPilDENiFLAG:  PROCEDURE; 

IF  TOKEN  =  02  THEN  FI LE$DESC$FLAG  =  TRUE; 
IF  TOKEN  =  47  THEN  REDEF^FLAG  =  TRUE? 

END  dup$iden$flag; 

lookahead:  procedure; 
if  nclook  then 
do; 
CALL  scanner; 
call  dup$iden$flag; 
nolook=false; 
if  print$token  then 

DO? 

C  ALL  CRLF > 

CALL  PRINT$NUMBER(TOKIN)J 

CALL  PRINTSCHAR1  '  '); 

CALL  print$accum; 

end; 
end; 
end  look  ahead; 

no$conflict:  procedure  (cstate^  byte; 
declare  (cstate, i,j,k)  byte; 
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j=index1(cstate); 

k=j  +  index2(cstate)  -  1? 

do  i=j  to  kj 
if  readl(i)=token  teen  return  true; 

end; 

return  false? 
end  no$conflict; 

recover:  procedure  byte? 
declare  (tsp,  rstate)  byte? 
DO  forever; 
tsp=sp; 

DO  WHILE  TSP  <>  255; 

if  no$conflict(rstate:=statestack(ts?) )  then 
do;  /*  state  will  read  token  */ 

if  spots?  then  sp  =  tsp  -  1 ; 

return  rstate? 
end; 
TSP  =   TSP   -  1; 

end; 

call  scanner;  /*  try  another  token  */ 
end; 
end  recover? 

end$pass:  procedure; 

/*  this  procedure  stores  tee  information  required  3y 
papt2  in  locations  above  the  symbol  table.  tee  following 
information  is  stored: 

output  file  control  block 

compiler  toggles 

input  buffer  pointer 
the  output  euffer  is  also  filled  so  the  current  record. 
is  written  */ 

call  byte$out(scd); 

call  addr$0ut(next$availa3le); 

do  while  output$ptr<>.ootput$buff? 

call  byte$out(0f?h); 
end; 

call  move( .output$fcb,max$memory-passl$len,passl$len); 
l:  go  to  l?  /*  patch  to  'jmp  3100h  '  */ 
END  end$pass; 

/*****  PROGRAM  EXECUTION  STARTS  HERE  *  *  */ 
CALL  MOVE(INITIALiPOS,MAX$MEMORY,RDR$LENGTu) J 

CALL  initsscanner; 
CALL  init$symbol; 


/*  $  *  #  #  *  *  PARSER  ******/ 

DO  while  compiling; 
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if  state  <=  maxrno  then  /*  read  state  */ 
do; 

call  incspj 

statestack(sp)  =  state;  /*  save  current  stats  */ 

CALL  lookahsad; 

I-GETIMi; 

J  =  I  +  GETIN2  -  l; 
DO  1=1  TO  J? 

if  readki  )  =  token  then 
do; 

/*  copt  the  accumulator  if  it  is  an  input 
string.  if  it  is  a  reserved  word  it  does 
not  need  to  be  copied.  */ 
if  (token=lnput$str)  or  ( token=literal)  then 
do  k=0  to  accum(0); 
varc(k)=accum(k); 
end; 

state=read2(i); 
nolook=true; 
i=j; 
end; 

ELSE 

if  i=j  then 
do; 
CALL  print$error('np'); 

CALL  PRINT(.C  ERROR  NEAR  $'))» 

CALL  print$accum;. 

if  (state:=rscover)=0  then  compiling=false; 
end; 
end; 
end;  /*  end  of  read  state  */ 

ELSE 

if  state>maxpno  then  /*  apply  production  state  */ 
do; 

mp=s?  -  getin2j 

mppi=mp  +  1; 

CALL  CODE$GEN( STATE  -  MAXPNO); 

SP=MPJ 

I=GETINi; 

J=STATSSTACK(SP); 

DO  WHILE  (K:=AP?LY1( I) )  <>  0  AND  JOKJ 

1=1  +  i; 

end; 

if  (k:=a??ly2(i))=0  then  compili ng=falsej 
state=k; 
end; 

ELSE 

if  state<=*axlno  then  /*lookahead  state*/ 
do; 

I=GETINi; 

call  lookahsad; 

do  while  (k:=lookl(i ))<>0  and  token  <>i; 

1=1+1; 
end; 
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STATE=L00K2(I); 

END; 

ELSE 

do;  /*pdsh  states*/ 
call  incspj 
statestack(sp)=getim2j 

STATE =GETINi; 

end; 
end?  /*  of  while  compiling 

CALL  END$PASS; 

end; 
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part2:  /*  module  name  */ 
do; 

/*  cobol  compiler  -  part  2  */ 

/*  100h  =  module  load  point  */ 

/*  global  declarations  and  literals  */ 

declare  lit  literally  'literally';  declare 
pass1uen  lit  '48', 
max$memory  lit  '0d100h', 
passutop  lit  '0d000h', 

CR    LIT    '13', 

LF   LIT    '10', 

QUOTE    LIT    '27H', 

POUND    LIT    '23H', 

TRUE   LIT    '1', 

FALSE   LIT    '0', 

FOREVER   LIT    'WHILE    TRUE', 

ALPHA$LIT$FLAG   EYTE    I NI TI AL( FALSE ) , 

IF^FLAG      BYTE      IN ITIAL( FALSE ) ;      DECLARE      MAXRNO      LITERALLY 
'82',/*    MAX    READ    COUNT    */ 

MAXLNO    LITERALLY    '105',/*   MAX    LOOK    COUNT   */ 
MAXPNO    LITERALLY    '120',/*    MAX    PUSH    CCUNT    */ 
MAXSNO    LITERALLY    '213',/*    MAX    STATE    COUNT   */ 
STARTS    LITERALLY    '1';/*    START    STATE    */ 
DECLARE    READK*)    BYTE 

DAT A (0,63, 5, 6, 9, 14, 16, 20, 2 2, 24, 26, 31, 32, 4 1,42, 44, 45       ,49,53 
,54,5e,60, 48, 28, 48, 29,28, 29, 36,37, 48, 59, 11 ,35,46 
,34,13,28,29,3  6,37  ,48 ,3 , 1 ,40 ,23 ,43 ,57 , 1 ,56 , 2 ,30 ,43 ,27 t 19 

,33,50,52,64,18,4,38,28,39,48  , 61 ,55 , 1 , 15 ,7 , 12 , 10 ,51 , 5 ,9 

,14,16,20,22,24,26,31,41,42,44,45,49,53,54 
,58,60,51,7,17,1,1 

,5,9,14,16,20,21,22,24.26,31,41,42,44,45,49,53,54 
,54,58,60,48,62,8,48,25,0,0); 
DECLARE    LCOKK*)    BYTE 

DATA( 0,43, 0,40, 0,2, 0,40, 0,1, 15, 0,43, 0,30, 43, 0,2, 0,27, 0,7 
,0,17,  0,1, 15, 0,55, 0,55, 0,55, 0,55, 0,1, 15, 0,12,2,1, 0,51,0 
,48,0);  ,0,25,0,3,43 
DECLARE    APPLYK*)    BYTE 
DATA (0,0, 22, 0,6, 0,0, 77, 0,0, 81, 0,11, 66, 68, 74, 79, 0,0. 3, 31,0 
,3, 81, 0,25, 0,0, 0,0, 57, 53, 59, 0,0, 0,0, 0,0,0, 69, 0,0, 0,0, 0,0 
,5,7,3,13,14  ,44,0,0,2,5,6,7,8,12,13,14,13,21,23,24,26 

,27,28,29,33,3^,40,44,75,76  ,77,30,0,9,30,37,38,49,52,54 

,0,5,7,8,13,14,28,44,0,52,0,20,0,0,15 ,  ,32  ,53 , 65 ,0  ,0  ,0  ,3  , 

81,0,0); 

DECLARE    RSAD2(*)    BYTE 
DATA (0,41, 6, 2 13, 9, 10, 33, 15, 17, 13, 20, 23, 24, 27, 23, 29, 30, 3 2 
,33, 34, 37, 38, 3 1,201, 85, 84, 2 01, 205, 2 07, 206. 85, 173, 194. 192 
,193,185  ,172,210,20  5,207,206,209,202,129,26,191 

,197,86,3,35,4,189,138,21 ,157  ,168,166,161,162,14,5 

,131,201,25,35,39,169,2,11,7,164,174,184,6,9,10  ,33 

,15,1?, 18, 20, 23, 27, 28, 29, 30, 32, 33, 34, 37, 38, 184, 8, 13, 130 
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,131,6,9,10  ,83,15,16,17,18,20,23,27,28,29,32 

,32,33,34,37,38,19,8,40,121,198,19,0,0); 

DECLARE  LC0K2(*)  BYTE 

DAT A (0,12, 106, 22, 107, 198, 199, 36, 108, 142, 142, 124, 44, 109, 45 
,45,110,46,196,47,111,112,49,113,52,114,114,54,56,115,57 
,116,58        ,117,59,118,119,119,63,64,120,147,67,69,139,75 
,122,78,136,128,128,81); 
DECLARE  AP?LY2(*)  BYTE 

DATA (0,0, 137, 60, 76, 103, 77, 127, 126, 105, 73, 72, 151, 150, 152 
,177,149,132,133,104,104,136,102,102,139,182,74,160,48 
,65,155,153  ,156,154,148,68,134,61,94,146,66,173 

,79,159,55,186,80,96,144,97,98  ,95,175,135,190,42,90 

,87,90,90,215,90,90,217,179,138,38,124,89,90  ,157,91 

,158,143,90,125,125,42,145,43,92,50,51,93,203,203,53,211 
, 195, 195, 195, 195, 195, 195, 195, 20*, 71, 70, 208, 212, 17 1,62 
,99,213,163,130  ,140  ,141 , 101 , 101 ,147 ,82 ) J 
DECLAPE  INDEXK*)  BYTE 

DATA (0,1, 115, 2, 22, 115, 11 5, 11 5, 115, 23, 25, 73, 11 5, 115, 115, 
,26,31,32,115,35,36,115,44,115,115,26,115,115,115,115 
,23,42,26,115  ,115,43,44,23,23,45,115,47 

,48,50,115,51,50,53,54,23,59,60,23,61,62,65,        ,66,66,66 
,66,67,68,69,26,70,26,73,71 ,73,91,92,93,94,95,96,115,115,117 
,119,73,115,2,26,1,3,5,7,9,12,14,17,19,21,23,25,23,30,32 
,34,36,39,  ,41,43,45,47,49,216,123,123,176 

,187,130,204,204,183,170,170,170,17  0  ,214,165,1,2 

,2,4,4,6,6,7,7,9,9,10,10,10,12,12,12,12,12,12,12,12,12,12, 

,12,12,12,12,18,18,18,18,19,19,19,19,22,22,22,25,27,27,27 
,28,28,29,29  ,29,30,30,34,34,35,35,36,36,37,37,33 

,38,39,39,39,40,42,43,43,44,44  ,45,45.46,46,46,47 

,47,54,5  5,80,8  0,80,88,96,96,98,98,98,130,100,100 

,101,101,106,106,107,107,108,111); 
DECLARE  IMDEX2(*)  BYTE 

DATA (0,1, 1,20, 1,1, 1,1, 1,2, 1,18, 1,1, 1,5, 1,3, 1,1, 6, 1,1,1, 
,5,1,1,1,1,2,1,5,1,1,1,1,2,2,2,1,1,2,1,1,2,1,1,5,2,1,1,2 
,1,3,, 1,1,1  ,1,1,1,1,1,5,1,5,13,2,18,1,1.1,1,1,19 

,1,2, 2,1, 18, 1,20, 5, 2, 2, 2, 2, 3, 2,  ,3,2,2,2,2,3,2 

,2,2,2,3,2,2,2  ,2,2,3,12,22,36,44,45,47,49,52,54,56,57, 

,58,59,63,64,5,1,0,0,1,0,1.2,2,1,2,0,0,2,1,0,2,1,0,2,1,1 
,3,3,2,3,0,1,  ,2,2,4,2,5,4,4,5,1,1,2,2,0 

,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,1,1 

,0,0,1,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,3,0,0,0,0,0,0.0,0 
,0,0,0,0,0,0  ,1,0); 

/*  END  07  TABLES  */ 
DECLARE 

/*  JOINT  DECLARATIONS  */ 

/*  THE  FOLLOWING  ITEMS  ARE  DECLARED  TOGETHER  IN  THIS 

GF.OUP  IN  ORDER  TO  FACILITATE  THEIR  BEING  PASSED  FROM 

THE  FIRST  PART  OF  THE  COMPILER. 

*/ 

OUTPUT^FCB         (33)    BfTE, 

DEBUGGING    BYTE, 

?RINT$?ROD    BYTE, 

PRINT$TOEEN   BYTE, 
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LIST$INPUT        BYTE, 

SEQ$NUM  BYTE, 

NEXT$SYM     ADDRESS , 

POINTER     ADDRESS,  /*  POINTS  TO  THE  NEXT  BYTE 

TO  BE  READ  */ 
NEXT$AVAILABLE  ADDRESS, 
MAX$INT$MEtf   ADDRESS, 

HASH$TAB$ADDR   ADDRESS,    /*  ADDRESS  OF  THE  BOTTOM  OF 

TEE  TA3LES  FROM  PARTI  */ 

/*  I  0  BUFFERS  AND  GLOBALS  */ 
INiADDR  ADDRESS  INITIAL  (5CH), 
INPUTFCB  BASED  INADDR  (33)  BYTE, 
OUTPUT$BUFF   (128)      BYTE, 
OUTPUT^PTR      ADDRESS, 
OUTPUTSEND      ADDRESS, 
OUTPUT$CHAR   BASED  OUTPUT$PTR  BYTE; 

/*  MESSAGES  FOa  OUTPUT  */ 

DECLARE 

ERROR$NEAR$$  (*)  BYTE  DATA  ('  ERROR  NEAR  $'), 
ENL$0F$?ART$2(*)  BYTE  DATA  ('  END  OF  COMPILATION  $'}', 

/*  GLOBAL  COUNTERS  */ 

DECLARE 
CTR  BYTE, 
A$CTR  ADDRESS, 
BASE  ADDRESS , 
3$BYTE  BASED  BASE  BYTE, 
B$ADDR  BASED  BASE  ADDRESS  J 

MON1:  PROCEDURE  (F,A)  EXTERNAL; 

DECLARE  F  BYTE,  A  ADDRESS; 
END  MONi; 

M0N2:    PROCEDURE    (F,A)    BYTE    EXTERNAL; 

DECLARE  F  BYTE,  A  ADDRESS; 
END  M0N2; 

BOOT:  PROCEDURE  EXTERNAL; 
END  BCCTJ 

PRINTCHAR:  PROCEDURE  (CHAR); 

DECLARE  CHAR  BYTE; 

CALL  MONI  (2, CHAR) J 
END  PRINTCHAR; 

CRLF:  PROCEDURE; 

CALL  PRINTCHAR(CR); 

CALL  PRINTCHAR(LF); 
END  CRLF; 

PRINT:  PROCEDURE  (A); 
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d7clar2  a  ad ires sj 
call  m0n1  (9, a)j 

end  print; 

print$error:  procedure  (code); 
/*  this  procidure  is  used  to  print  compiler  errors  to 

the  consol  */ 
declare  code   address, 

I      BYTEt 

c0dek6)  address; 
ie  code  =  false  then 
do; 

DO   I    =   0   TO   5; 
CCDEl(I)    =  0; 

end; 
i  =  0; 

end; 

ELSE 

ie  code  =  true  then 
do; 
i  =  0; 

do  while((i<>6)  and  (codel(i)  <>  0)); 
call  crlf; 

call  printchar(high(codel( i) ) ); 
call  printcfar  ( low ( cods1 ( i )  )  ) ; 

CODEl(I)  =  0; 
I  =  I  '+  15 
END; 

i  =  0; 
end; 

ELSE 

if  (code  =  'np')  or  (code  =  'nv')  or  (code  =  'sl')  then 
do; 

call  crlf; 

call  ?rintchar(high(c0de)  )j 

call  printchar(  low(code)); 
end; 

ELSE 

do; 

IF  I  <>  6  THEN 

do; 
codeki  )  =  code; 
I  =  I  +  l; 
end; 
end; 
end  print^error; 

fatal$error:  ?rocedure( reason ) j 

declare  reason  address? 

call  print$error(reason); 

call  print$srror(true); 

call  time (10); 

CALL  eoot; 
end  fatal^error; 
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CLOSE:  PROCEDURE; 

IF  M0N2(16, .0UTPUTiFCB)=255  THEN  CALL  FATAL$ERROR ( 'CL ' ) I 

END  close; 

MORE$INPUT:  PROCEDURE  BYTE; 

/*  READS  THE  INPUT  FILE  AND  RETURNS  TRUE  IF  A  RECORD 

WAS  READ.  FALSE  IMPLIES  END  OF  FILE  */ 
DECLARE  DCNT  BYTE? 
IF  (DCNT:=MON2(20, .INPUT^FCB) )>1  THEN 

CALL  FATAL^ERRORl 'BR' ); 
RETURN  NOT(DCNT); 
END  MOREilNPUT? 

WRITE$OUTPUT:  PROCEDURE  (LOCATION); 

/*  WRITES  OUT  A  128  BYTE  3UFFER  FROM  LOCATION*/ 

DECLARE  LOCATION  ADDRESS; 

CALL  M0N1(26, LOCATION );  /*  SET  DMA  */ 

IF  M0N2(21,  .CUT?UT$FCB)<>0  THEN  CALL  FATAL^ERRCR ( 'WR ' ) ; 

CALL   MON1(26,80H);    /*RESET    DMA    */ 

END  write$output; 

move:  ?rocedure(source,  destination,  count); 
/*  moves  fop  the  number  cf  bytes  specified  by  count  */ 
declare  (source, destination)  address, 
(s$byte  based  source,  d^byte  based  destination,  count) 
byte; 
do  while  (count:=ccunt  -  1)  <>  255; 
d$byts=s$byte; 
source=source  +1j 
destination  =  destination  +  1j 
end; 
end  move; 

fill:  procedureuddr,  char,  count)  ; 
/*  moves  char  into  addr  for  count  bytes  */ 
declare  addr  address, 
(char, count, dest  based  addr)  byte; 
do  while  (ccunt:=count  -1)<>2555 
dest=ch*r; 
addr=addr  +  1j 
end; 
end  fill; 

/*  *  *  *  *  *  scanner  lits  *****/ 

DECLARE 
LITERAL 
INPUT5STR 
PERIOD 
PPARIN 
LPARIN 
INVALID 

/*  *  *  #  *  SCANNER  TABLES  *  *  *  *   */ 
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LIT 

'29', 

LIT 

'48', 

LIT 

'1', 

LIT 

'3', 

LIT 

'2', 

LIT 

'0'; 

DECLARE  T0KEN$TA3LE  (*)  BYTE  DATA 

/*  CONTAINS  THE  TOKEN  NUMBER  ONE  LESS  THAN  THE  FIRST 
RESERVED  WORD  FOR  EACH  LENGTH  OF  WORD  */ 
(0,0,3,7,13,29,41,48,56,60,63) , 

TABLE  (*)  BYTE  DATA (  'BY  ' ,  'GO  ' ,  'I F' ,  'TO ' , ' EOF ' , ' ADD ' , 'EN D ' 
'I-O'  ,  'NOT',  'RUN', 'CALL', 'ELSE',  'EXIT' ,  'FROM  '  ,  'I NTO  ' 
'LESS',  'MOVE'  , 'NEXT',  'OPEN',  'PAGE' , 'READ' , 'SIZE' , 'STOP' 
'THRU',  'ZERO'  , 'AFTER',  'CLOSE', 'ENTER', 'EQUAL',  'ERROR' 
'INPUT', 'QUOTE',  'SPACE'  ,  'TIMES  ' , 'UNTI L ' . 'US ING ' , 'WRITE' 
'ACCEPT', 'BEFORE', 'DELETE'  ,  'DIVIDE',  'OUTPUT',  'DISPLAY' 
'GREATER'  r 'INVALID' , 'NUMERIC ', 'PERFORM', 'REWRITE' 

'ROUNDED', 'SECTION'        ,  'DIVISION  '  ,  'MULTIPLY', 'SENTENCE' 
'SUBTRACT', 'ADVANCING' ,  'DEPENDING', 'PROCEDURE ' 

'ALPHABETIC')  , 

OFFSET  (11)  ADDRESS  INITIAL 

/'*  NUMBER  OF  BYTES  TO  INDEX  INTO  THE  TAELS  FOR 
EACH  LENGTH  */ 

(0,  0,0,8,26,86, 146, 176, 232, 264, 291)  , 

WORD$COUNT  (*)  BYTE  DATA 

/*  NUMBER  OF  WORDS  OF  EACH  SIZE  */ 
(0,0,4,6,15,12,5,8,4,3,1), 

max$id$len   lit   '12', 

maxhen   lit    '10', 

add^end        (*)  byte  data  ('eof  '), 

looked         bite  initial  (0), 

hold  byte, 

eoffiller   lit   '1ah', 

buffer$end   address  initial  (100h), 

next     based  pointer   3yte, 

inbuff    lit    '80h', 

char     byte   initial(  '  '), 

accum  (82)   byte, 

display  (82)  byte  initial  (0), 

token    byte;    /^returned  from  scanner  */ 

/*  procedures  used  by  the  scanner  */ 

next$char:  procedure  byte; 
if  looked  then 
do; 

looked=false; 

return  (cear:=hcld); 
end; 

if  (pointer:=pcinter  +  1)  >=  5uffer$7nd  then 
do; 
if  not  more$ input  then 

do; 

BUFFSRiEND=. MEMORY; 

pointer^. add$end» 

end; 

else  pointer=inbuff; 
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end; 

if  next  =  eoffiller  then 
do; 
buffer$end  =  .memortj 
pointer  =  ,add$end; 
end; 

return  (char:=next)j 
END  next$char; 

get^char:  procedure; 
/*  this  procedure  is  called  when  a  new  char  is  needed 
without  the  direct  return  of  the  character*/ 
char=next$char; 

end  get$char; 

display$line:  procedure; 

if  not  list$input  then  return; 

dis?lay(displat(0)  +  1)  =  '$'; 

call  print( .display(l)); 

display(0)=0j 
END  display$line; 

LOAD$DIS?LAY:    PROCEDURE; 
IF   DISPLAY(0)<e9    THEN 

DISPLAY (D  IS  PLAY (0) :=DISPLAY (0 ) +1 )=CHAR; 
CALL  GET$CFAR> 

SND  load^display; 

put:  procedure; 

if  accum{0)  <  60  then 

accum( accum(0) :=accum (0 ) +1 ) -char? 

CALL  load$dis?lay; 
END  put; 

EAT$LINE:  PROCEDURE; 
DO  i/HILE  CHAROCR; 

call  load$displayj 
end; 
snd  eat$line; 

get$no$blank:  procedure; 

DECLARE  (Ntl  )  BYTE; 

DO  forever; 

IF  CHAR  =  '  '  THEN  CALL  LOAD$DIS PLAY ; 
ELSE 

if  char=cr  then 
do; 

call  display$line; 

call  printisrror(trus); 

if  secinum  then  n=9j  else  n=2j 

DO  I  =  1  TO  n; 

call  lcad$display; 
end; 
IF  CHAR  =  '*'  then  call  eat$line; 
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end  ; 

ELSE 

if  char  =  ':  '  then 
do; 

if  nct  debugging  then  call  eathinej 

ELSE 

CALL  load$display; 
end; 

ELSE 

return; 
end?  /*  end  cf  do  forever  */ 

END   GET$NO$BLANiC; 

SPACE:  PROCEDURE  BYTE; 

RETURN    (CHAR='    ')    OR    (CHAR=CR)J 

END  space; 


LEFT$PARIN:  PROCEDURE  BYTE; 
RETURN  CHAR  =  '( '? 

END  left$parin; 

RIGHT$PARIN:  PROCEDURE  BYTE; 
RETURN  CHAR  =  ')'» 

END  right$parin; 

delimiter:  procedure  byte; 

/*  checks  for  a  period  followed  by  a  space  or  cr*/ 

if  char  <>  '.'  then  return  false; 

hold=next$char; 

looked-true; 

if  space  then 

do; 

CHAR  =  '. '; 
return  true; 

end; 

char='. '; 

return  false? 
end  delimiter; 

end*cf$token:  procedure  byte? 

return  space  or  delimiter  or  left$?arin  or  right$parinj 
END  end$of$token; 

GET$LITERAL:  PROCEDURE  3YTE? 

CALL  load^display; 
do  forever; 

if  char  =  quote  then 
do; 

call  load$dis?lay: 
return  literal; 
end; 

call  put; 
end; 
end  get$ literal; 
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LOOK$UP:  PROCEDURE  BYTE; 
DECLARE  POINT  ADDRESS, 
HERE  BASED  POINT  (1)  BYTE,  I  BYTE; 

MATCH:  PROCEDURE  BYTE; 
DECLARE  J  BYTE? 
DO  J=l  TO  ACCUM(0)J 

if  here(j  -  1)  <>  accum(j)  then  return  false; 
end; 

return  true; 
end  match; 

point=offset(accum(0) )+  .ta3le; 
do  1=1  to  word$count(accum(0)); 

if  match  then  return  i j 

point  =  point  +  accum(0) ; 
end; 

return  false; 
end  look$up; 

reserved$word:  procedure  byte? 
/*  returns  the  token  number  of  a  reserved  word  if  tee 
contents  of  the  accumulator  is  a  reserved  word, 
otherwise  returns  zero  */ 
declare  value  byte; 
declare  numb  byte; 
if  accum(0)  <=  max^len  then 
do; 

if  (numb:=token$taels( accum(0) ))<>0  then 
do; 
if  (value:=loo£$u?)  <>  0  then 

numb=numb  +  value; 
else  nume=0; 
end; 
end; 

else  numb=0j 
return  numb; 
END  reserved$word; 

SET$TOKEN:    PROCEDURE    3YTE; 
ACCUM(0)=0; 

CALL  g-et$no$blank; 

IF   CHAR=OUOTE   THEN    RETURN    G-STUITERAL; 

if  delimiter  then 
do; 

CALL  put; 

RETURN  PERIOD; 

end; 

I?  LEFT$PARIN  THEN 

DC- 
CALL  put; 
return  lparinj 

end; 
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if  fight^parin  then 
do; 

CALL  put; 
return  rpapin; 
end; 

do  forever; 
call  put; 

ie  end$of$token  then  return  input$strj 
end?  /*  of  do  forever  */ 
end  get$tokenj 
/*  end  of  scanner  routines  */ 
/*  scanner  exec  */ 
scanner:  procedure; 
if(token:=get$token)  =  input$str  then 

if  (ctr:=reserved$w01d)  <>  0  then  token=ctr; 
END  scanner; 

?RINT$ACCUM:  PROCEDURE; 
ACCUM( ACCUM(0)+1)='$'; 
CALL  PRINT( . ACCUM(l)) ; 
END  PRINT$ACCUMJ 
PRINT$NUM3ER:  PROCEDURE (NUMB) J 

DECLARE(NUMB,I,CNT,£)  BYTE,  J  (*)  BYTE  D  ATA(  100  ,  10  )  ,* 
DO  1=0  TO  i; 
CNT=0J 

DO  WHILE  NUMB  >=  (K:=J(I))J 
NUMB=NUMB  -  K; 
CNT=CNT  +  I? 

end; 

call  printcfar( '0'  +  cnt); 
end; 

call  printcharc0'  +  numb); 
END  print$numbsr; 

/*  *  *  #  snd  OF  SCANNER  PROCEDURES  *  *  *  */ 
/*****  SYMBOL  TABLE  DECLARATIONS  *  *  *  */ 

DECLARE 

CUR$SYM       ADDRESS,     /*SYM30L  BEING  ACCESSED*/ 

SYMBOL       BASED  CUR$SYM  (1)  BYTE, 

SYMBOL$ADDR     BASED  CUR$SYM  (1)  ADDRESS, 

NSXTSSYM$SNTRY    BASED  NEXT$SYM    ADDRESS, 

HASH^MASK  LIT  '3FH ' , 

S$TYPE  LIT  '2', 

DISPLACEMENT     LIT     '13', 

OCCURS       LIT     '12', 

P$LENGTH       LIT       '3', 

FLD$LENGTH     LIT       '3', 

LEVEL       LIT       '10', 

DECIMAL      LIT       '11', 

REL$ID       LIT       '5' 

LOCATION       LIT       '2  , 

START$NAME      LIT       '12',  /*1  LESS*/ 

FCB$ADDR       LIT     '4', 

/**#***#  SYMBOL  TYPE  LITERALS  *******/ 

UNRESOLVED     LIT     '255', 

LABEL$TYPE     LIT     '32', 
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MULT$OCCURS  LIT  '123', 

GROUP  LIT  '6\ 
NON$NUMERIC$LIT   LIT     '7', 

ALPHA  LIT  '8', 

ALPHA$NUM  LIT  '9', 

LITiSPACE  LIT  '10', 

LIT$QUGTE  LIT  'll'f 

LIT$ZERO  LIT  '12', 
NUMERIC$LITERAL   LIT     '15', 

MUMERIC  LIT  '16', 

COMP  LIT  '21', 

A$ED  LIT  '72', 

A$N*ED  LIT  '73', 

num$ed     lit   '80'j 
/*  *  *  *  symbol  table  routines  *  *  *  */ 

set$address:  procedure! addr ) j 
declare  addr  addpessj 

symbol$addr(location)=addr; 
end  set$address; 
get$address:  procedure  address,* 

return  symbol$addr(location); 
end  get$address? 
get$fcb*addr:  procedure  address; 

return  symbol$addr(pcb$addr); 
END  get^fcb$addr; 

GET$TYPE:  PROCEDURE  BYTE? 
RETURN  SYMBOL(S^TYPE) ; 

END  get$type; 

SETSTYPE:  PROCEDURE! TYPE) J 
DECLARE  TYPE  BYTE; 
SYMBCL(S$TYPE)=TYPE? 

END  set$type; 

GET$LENGTH:    PROCEDURE  ADDRESS; 
RETURN    SYMBOL$ADDR(FLD$LENGTH) ; 

END  get$length; 

GET^LEVEL:    PROCEDURE   BYTE; 
RETURN    SYMBOL(L?VEL); 

END  get$level; 

getsdecimal:  procedure  byte; 

return  symbol(decimal); 
end  get$decimal; 
get$p$length:  procedure  byte; 
return  symbol(p$lengte); 
END  get$p$length; 
build$symbol:  procedure (lsn ) ; 

declare  len  byte,  temp  address  j 

temp=next$sym; 

i?  (next$sym:=.symbol(len:=len  +  displacement)) 
>  max$memory  teen  call  fatalserrcr ( 's t ' ) ; 

call  fill  (temp, 0, len); 
END  build$symbol; 

AND$OUT$OCCURS :  PROCEDURE  (TYPS^IN)  BYTE; 
DECLARE  TYPE$IN  BYTE; 
RETURN  TYPE$IN  AND  127; 
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END  AND$OUT$OCCURS; 

/*  *  *  *  PARSE?  DECLARATIONS  *  *  *  */ 
DECLARE 

PSTACKSIZE   LIT     '30',    /*  SIZE  0?  PARSE  STACKS*/ 
VALUE      (PSTACKSIZE)   ADDFESS,  /*  TEMP  VALUES  */ 
STATESTACK   (PSTACKSIZE)   BYTE,  /*  SAVED  STATES  */ 


(PSTACKSIZE)   ADDRESS,    /*  VALUE2  STACK*/ 
(100)      BYTE,    /*TEMP  CHAR  STORE*/ 

(20)  ADDRESS, 
BYTE, 
BASED      MAX$INT$MEM      BYTE, 

BYTE  INITIAL   (0), 
BYTE, 


VALUE2 

VARC 

ID$STACK 

ID$PTR 

MAX$BYTE 

SUB$IND 

COND$TYPS 

HOLDiSECTION  ADDRESS, 

HOLD$SEC$ADDR  ADDRESS, 


INITIAL 


INITIAL 


(0), 
(FALSE) 


SECTION$FLAG  BYTE 

L^ADDR     ADDRESS, 

DISPLAY^FLAG  BYTE 

L^LENGTH    ADDRESS, 

L$TYPE     BYTE, 

L$DSC      BYTE, 

CON$LENGTH   BYTE, 

COMPILING    BYTE   IN  ITI AL ( TRUE ) , 

SP       BYTE   INITIAL  (255) , 

MP       BYTE, 


MPP1 
NOLOOK 
(I,J,K) 
STATE 
/*  *  * 

/*  THE 
ON  THE 


BYTE, 

BYTE 
BYTE, 

BYTE 
*  *  *  * 


INITIAL(FALSE), 

/*INDICIES  FOR 
INITIAL(STARTS), 
*  CODE  LITERALS  * 


THE  PARSER*/ 


CODE  LITERALS  ARE  BROKEN  INTO 
TOTAL  LENGTH  OF  CODE  PRODUCED 


#  *  #  *  #  *  */ 

GROUPS  DEPENDING 
FOR  THAT  ACTION  */ 


/*  LENGTH 


ADD 
SUB 
MUL 
DIV 


LIT 
LIT 
LIT 
LIT 


'1', 
'2', 

'3  ' 

-4-: 


MEG  LIT  '5', 

ST?  LIT  '6', 

STI  LIT  '7', 

/*  LENGTH 

RND  LIT  '8', 

/*  LENGTH 

RET  LIT  '9', 

CLS  LIT  '10' 

SER  LIT  '11' 

BRN  LIT  '12' 

OPN  LIT  '13' 

0P1  LIT  '14' 

0P2  LIT  '15' 

RGT  LIT  '16' 

RLT  LIT  '17' 

REQ  LIT  '18' 


ONE  : 
/* 
/* 

/* 

/* 

/* 
/* 
/* 

TWO 
/* 


7 

ADD  REGISTER  1  TO 
SUBTRACT  REGISTER 
MULTIPLY  REGISTER 
DIVIDE  REGISTER  0 
(NO  REMAINDER)  */ 
NOT  OPERATOR  */ 
STOP  PROGRAM  */ 


REGISTER  0  */ 
1  FROM  REGISTER  0  : 
0  BY  REGISTER  1  */ 
BY  REGISTER  1 


STORE  REGISTER  2  INTO  REGISTER  2    */ 

*/ 

ROUND  CONTENTS 

THREE  */ 
/*  RETURN  */ 
/*  CLOSE  */ 
/*  BRANCH  ON 
/*  BRANCH 
/*  OPEN  A 
/*  OPEN  A 
/*  OPEN  A 
/*  REGISTER 
/*  REGISTER 
/* 


OF  REGISTER  2  */ 


SIZE  ERROR  */ 

*/ 

FILE  FOR  INPUT  */ 
FILE  FOR  OUTPUT  */ 
FILE  FOR  BOTH  INPUT 

GREATER  THAN  */ 

LESS  THAN  */ 


AND  OUTPUT  */ 


REGISTER  EQUAL  */ 
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INV  LI 

EOR  LI 

/* 

ACC  LI 
STD  LI 
LDI  LI 

/* 
DIS  LI 
DEC 
STO 
ST1 
ST2 
ST3 
ST4 
ST5 


T  '19' 
T  '20' 
LENGTH 
T  '21' 
T  '22' 
T  '23' 
LENGTH 


LI 
LI 
LI 
LI 
LI 
LI 
LI 

/* 

LOD  LI 

LDI 
LD2 
LD3 
LD4 
LD5 
LD6 


LI 
LI 
LI 
LI 
LI 
LI 

/* 

PER  LI 

CNU 

CNS 

CAL 

RWS 

DLS 

RDF 

WTF 

RVL 

WVL 


LI 
LI 
LI 
LI 
LI 
LI 
LI 
LI 
LI 
/* 
SCR  LI 


SGT 
SLT 
SEQ 
MOV 


LI 
LI 
LI 
LI 
/* 

RRS  LI 

WRS 

RRR 

WRR 

RWR 

DLR 


'24' 
'25' 
'26' 
'27' 

'28' 
'29' 
'30' 
'31' 
LENGTH 
T  '32' 
'33' 
'34' 
'35' 
'36' 
'37' 
'38' 
LENGTH 
T  '39' 
'40' 
'41' 
'42' 
'43' 
'44' 
'45' 
'46' 
'47' 
'48' 
LENGTH 
T  '49' 
'50' 
'51' 
'52' 
'53' 


LENGTH 


LI 
LI 
LI 
LI 
LI 

/* 

MED  LI 
MNE  LI 

/* 
GDP  LI 

/* 
INT  LI 


'54' 
'55' 

'56' 
'57' 
'58' 
'59' 
LENGTH 
T  '60' 
T  '61' 
VARIAB 
T  '62' 
BUILD 
T  '63' 


/-BRANCH  IF  INVALIB-7ILE-ACTI0N  FLAG  TRUE*/ 
/*  BRANCH  ON  END-OF-PECORDS  FLAG  */ 
FOUR  */ 
/*  ACCEPT  */ 
/*  STOP  WITH  DISPLAY  */ 
/*  LOAD  A  CODE  ADDRESS  DIRECT 
FIVE  */ 
/*  DISPLAY  */ 

DECREMENT  COUNT  AND  BRANCH 
STORE  NUMERIC  */ 

SIGNED  NUMERIC  LEADING  */ 
SIGNED  NUMERIC  TRAILING  */ 
SEPARATE  SIGN  LEADING  */ 
SEPARATE  SIGN  TRAILING  */ 
A  PACKED  NUMERIC  FIELD  */ 


/* 

/* 
/* 
/* 
/* 

/* 

/* 

SIX 
/* 

/* 

/* 
/* 

/* 

/* 

/* 


*/ 


IF  ZERO  */ 


STO  HE 
STORE 
STORE 
STORE 
STORE 

*/ 

LOAD 

LOAD 
LOAD 
LOAD 
LOAD 
LOAD 
LOAD 
SEVEN  */ 
/*  PERFORM 
COMPARE 
COMPARE 
COMPARE 
REWRITE 
DELETE 


/* 
/* 
/* 
/* 

/* 
/* 

/* 

/* 

/* 


NUMERIC  LITERAL  */ 
NUMERIC  */ 

SIGNED  NUMERIC  LEADING  */ 
SIGNED  NUMERIC  TRAILING  */ 
SEPARATE  SIGN  LEADING  */ 
SEPARATE  SIGN  TRAILING  */ 
A  PACKED  NUMERIC  FIELD  */ 


*/ 

NUMERIC  UNSIGNED  */ 
NUMERIC  SIGNED  */ 
ALPHABETIC  */ 
SEQUENTIAL  */ 
SEQUENTIAL  */ 


READ  A  SEQUENTIAL  FILE  */ 
WRITE  A  RECORD  TO  A  SEQUENTIAL  FILE  */ 
READ  A  VARIABLE  LENGTH  FILE  */ 
WRITE  A  VARIABLE  LENGTH  RECORD  */ 
NINE  */ 
/*  CALCULATE  A  SUBSCRIPT  */ 
/*  STRING  GREATER  THAN  */ 
/*  STRING  LESS  THAN  */ 
/*  STRING  EQUAL  */ 
/*  MOVE  */ 
TEN  */ 
/*  READ  RELATIVE  SEQUENTIAL  */ 
/*  WRITE  RELATIVE  SEQUENTIAL  */ 
/*  *EAD  RELATIVE  RANDOM  V 
/*  WRITE  RELATIVE  RANDOM  */ 
/*  REWRITE  RELATIVE  */ 
/*  DELETE  RELATIVE  */ 
ELEVEN  */ 
/*MOVE  INTO  AN  ALPHANUMERIC  EDITED  FIELD*/ 
/*  MOVE  INTO  A  NUMERIC  EDITED  FIELD  */ 
LE  LENGTH  */ 

/*  GO  TO  -  DEPENDING  ON  */ 
DIRECTING  ONLY  */ 

/*  INITIALIZE  MEMORY  */ 
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3ST  LIT  '64',  /*  BACK  STUFF  */ 

TER  LIT  '65',  /*  TERMINATE  BUILD  */ 

SCD  LIT  '66';  /*  START  CODE  */ 

/*  *  *  *  PARSER  ROUTINES  *****/ 
DIGIT:  PROCEDURE  (CHAR)  BYTE; 

DECLARE  CHAR  BYTE; 

RETURN  (CHAR<='9')  AND  (CHAR>='0'); 

END  digit; 

LETTER:  PROCEDURE  (CHAR)  BYTE; 
DECLARE  CHAR  BYTE; 
RETURN  (CHAR>='A')  AND  (CHAR<='Z')J 

END  letter; 

INVALID$TYPE:  PROCEDURE? 

CALL  print$error( 'it'); 
end  invalid$type; 
3yte*0ut:  procedure! one^byte) j 

declare  one$byte  byte; 

if  (output$?tr:=output$ptr  +  1)  >  outputsend  then 

do; 

call  write$output( .output^buff ) ; 
outputs ptr=. output $buff; 

end; 

output $char=one$byte; 
end  byte$out; 
addr$out:  procedure  (addr); 

declare  addr  address? 

call  byte$out(lov(addr) ); 

call  3yte$0ut(high  (addr))? 
END  addr^out; 

INC$COUNT:  PROCEDURE( CNT) ; 

DECLARE  CNT  BYTE; 

IF(NEXT$AVAILABLE:=NErT$AVAILABlE    +    CNT) 

>MAX$INT$MEM  THEN  CALL  FATAL$SRROR ( 'MO ' ) ; 
END  INC$COUNTi 
ONE$ADDR$OPP:  PROCEDURE (CODE, ADDR) J 

DECLARE  CODE  BYTE,  ADDR  ADDRESS; 

CALL  BYTEi OUT (CODE)? 

C4LL  ADDP$OUT(ADDR); 

CALL  INC$C0UNT(3); 
END  ONE$ADDR$OPPi 
NOT$IMPLlMENTED:  PROCEDURE; 

CALL  PRINT$ERROR  (  'NI  '); 

END  notMmplimented; 

MATCH:  PROCEDURE  ADDRESS; 

/*  CHECKS  AN  IDENTIFIER  TO  SEE  IF  IT  IS  IN  THE  SYMBOL 
TABLE.  IF  IT  IS  PRESENT,  CURSSYM  IS  SET  FOR  ACCESS, 
OTHERWISE  THE  POINTERS  ARE  SET  FOR  ENTRY*/ 
DECLARE  POINT  ADDRESS,  COLLISION  BASED  POINT  ADDRESS, 

(hold, i)  bite; 

IF    ORC(0)>MAX$ID$LEN    THEN    '/  «.RC  (  0  )=MAX$  ID$LEN  ; 
HOLD=0J 

DO    1=1    TO   VARC(0); 
HOLD=HOLD+VARC(I); 

end; 
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point=hash$tae$addr  +  shl((hold  and  hashsmask ) , 1 ) j 
do  forever; 
if  collision=0  then 
do; 
CUR-pSYM  ,collision=next$sym; 

CALL  BUILD$SYMBOL(7ARC(0)); 
SYMBOL(P$LENGTE)=VARC(0); 

do  1=1  to  varc(0); 

symbol (start$name+i )=varc(i )> 
end; 

CALL  SET^TYPE(UNRESOLVED);  /*  UNRESOLVED  LABEL  */ 
RETURN  CURSSYM; 

end; 

ELSE 

do; 

cur$sym=collision; 

if  (hcld:=get£p$length)=varc(0)  then 
do; 
1=1; 

DC    WHILE    SYMBOL(START$NAMF    +    I )=    VARC(I); 

if  (i:=i+1)>h0ld  then  return ( cur^sym :=ccllis ion ) j 
end; 
end; 
end; 

?cint=collision; 
end; 
end  match; 

SET$VALUE:  procedure(numb); 
declare  numb  address; 
value (mp)=numb; 
end  sst$value; 

sst$value2:  procedure! addr ) ; 
declare  addr  address? 
value2(mp)=addr; 
end  set$value2j 
sub^cnt:  procedure  3ytej 

IF  (SUB$IND:=SU3$IND  +  1)>8  THEN 
SUB$IND-1J 

RETURN  5UB$IND; 

END  sub$cnt; 

CODESBYTS:  PROCEDURE  (CODE); 

DECLARE  CODE  BYTE; 

CALL  EYTE$OUT(CODE); 

CALL  INC$COUNT(l); 
END  C0DE$3YTE; 
CODE$ADDRESS:  PROCEDURE  (CODE); 

DECLARE  CODE  ADDRESS? 

CALL  ADDR$OUT(CODE); 

CALL  INC$C0UNT(2); 
END  CODEiADDRSSS? 

input^numeric:  procedure  3yte; 
do  ctr=1  to  varc(0); 

if  not  pigit(varc(ctr) )  then  return  false; 
end; 
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RETURN  TRUE,* 
END  INPUTSNUMERIC; 
CONVERT* INTEGER:  PROCEDURE  ADDRESS; 

ACTR=0J 

do  ctr=1  to  varc(0); 

if  not  digit(varc(ctr) )  then  call  pri nt$error ( 'nn' ) 
a$ctr=shl(actr,3)+shl(actr,1)  +  varc(ctr)  -  '0'j 
end; 

return  actr; 
end  conve?.t$integfr; 
backstuff:  procedure  (add1,add2); 
dfclare  (add1.add2)  address? 
call  byte^out(bst); 

CALL  ADDR$OUT(ADDl); 

CALL  ADDR$0UT(ADD2); 
END  3ACKSSTUFFJ 
UNRESOLVED$BRANCH:  PROCEDURE; 

CALL  SET$VALUE(NEXT$AVAILABLE  +1); 

CALL  ONE$ADDR$OPP(BRN,0); 

CALL  SET$VALUE2(NEXT$AVAILA3LE) ; 
END  UNRES0LVED$3RANCHJ 
BACKBOND:  PROCEDURE; 

CALL  BACKSTUFF(VALUE(S?-1),NEXT$A7AILABLE); 
END  BACKBOND? 
SET$BRANCH:  PROCEDURE; 

CALL  SET$VALUE(NEXT$AVAILABLE) ; 

CALL  CODE$ADDRESS(0); 

END  set$branch; 

kee?$values:  procedure; 
call  set$value(7alue(sp)); 
call  set$value2(value2(sp)); 
end  keep^valuss; 

get$rec$address:  procedure! record* addr )  address; 
declare  (record^addr,  hold$addp)  address; 
cur$sym=record$addr; 
hold*addr=get$address ; 
cur$sym=get$?cb$addr; 
return  h0ld5addr; 
end  c-etsrsc^address; 

get$rec$len:  procedure! record^addr  )  address; 
declare  (reccrdsaddr,  hold$length)  address; 
cur$sym=record*addr; 
hold$length=get$length; 
cur$sym=get$fce$addr; 
return  ecld$length; 
end  get$rec$len; 

std^attributes:  procedure ( type ) ; 
declare  type  byte? 
call  code$  address ( get$fcb*  addr ) j 
call  code$address(get$reci address (get$ address) ) ; 
call  code$address(get£rec£lsn(get*adpress) )j 
if  type=0  then  return; 
cur$sy.m=symbol$addrf  rel$id)  ; 
call  code$address (get$address ) ; 
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CALL  CODE$BYTE(GET$LENG-TH)J 
END  STD^ATTRIBUTESJ 
WRITE$A$RECORD:  PROCEDURE? 

IF  GET^LEVELOl  THEN  CALL  PRlNT$ERROR  (  "WL  ' )  J 
ELSE  do; 
cur$sym=get$fcb$addr; 
if  (ct?:=get$type)=1  then 
do; 
call  code$byte(wtf) j 
call  std$attributes(0); 

END; 

else  if  ctr=2  then 
do; 
call  code$byte(wrs); 
call  std$attri3utes(1); 
end; 

else  if  ctr=3  then 
do; 
call  code$byte(wrr); 
call  stdsattributes(l); 
end; 

else  if  ctr=4  then 
do; 
call  code^byte(vyl) ; 
call  std$attributes(0); 
end; 

else  call  print$err0r ( 'ft ' ) ; 
end; 
end  write$a$record; 
read$a^file:  procedure; 
if  (ctr:=get$type)=1  then 
do; 
call  ccde$byte(rdf) ; 
call  std$attpibutes(0); 
end; 

else  if  ctr=2  then 
do; 
call  code$byte(rrs) ; 
call  std^attributes(l); 
end; 

else  if  ctr=3  then 
do; 
call  code$byte(rrr) ; 
call  std$attributes(1); 
end; 

else  if  ctr=4  then 
do; 
call  c0de$3yte(rvl) j 
call  std$ attributes (0) j 
end; 

else  call  pr int$error ('ft  ' ) ; 
end  read^file; 

arithmetic$type:  procedure  byte; 
if  ( (l$type:=andiout$occurs(l$ty?e) ) >  =  wmeric$litsral ) 
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AND  (L^TYPE<=COPP)  THEN  PETUPN  L$TY?E  -  NUMEF IC$LI TEHAL ; 

CALL  invalid$type; 

RETURN  0J 

END  arithmetic$type; 

DELETE$A$FILE:  PROCEDURE; 
IF  (CTR:=GET$TYPE)=3  THEN 
DC- 
call  code$byte(dlr)  ; 
call  std^attributes(l); 
end; 

else  if  ctr=2  then 
do; 
call  code$byte(dls)  ,* 
call  std$attributes(0); 
end; 

else  call  pp int^error (  '  it  ' ) ; 
END  delete$a$file; 

REWRITE$A$RSCORD:    PROCEDURE? 

IF   G-ET^LEVELOl    THEN    CALL   PRINT$ERROR(  'WL' )  J 
ELSE  do; 

cur$sym=get$fcb$addr; 
if  (ctr:=g-et$ty?e)  =  3  then 

DC- 
CALL  CODEiBYTE(RWR); 

call  std$attkibutes(1); 
end; 

elsf  if  ctr=2  then 
do; 
call  cods$byte(rws); 
call  std$attributes(0); 
end; 

else  call  print$3rr0r( 'it' ) ; 
end; 
end  revrite$a$record; 
attributes:  procedure; 
call  code$address(l$addr); 
call  codeibyte(l$length); 
call  code$byte(l$dec) j 
2ND  attributes; 

L0AD$L$ID:  PROCEDURE (S$PTR) J 
DECLARE  S$PTR  BYTE; 

IF  ((A$CTR  :=  VALUE (S$PTR  )  )  <=  NON^NUMER IC$LIT )  OR 
(ACTR  =  NUMERIC^LITERAL)  THEN 

do; 

l$addr=value2(s?tr); 

l$leng-te  =  con*leng-th; 

l$typs=a$ctr; 

return; 
end; 

IF   A$CTR<=LIT$ZE?.0   then 

do; 

l$type,l£addr=a$ctr; 

l$length=i; 

return; 
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end; 

cur$sym=value(s$ptr); 
l$type=get$type; 
l$length=getilengthj 
l$dec=get$decimal? 

if(l$addr:=value2(s$?tr) )=0  then  l$addr=get$ address  ; 
END  load$l$id; 

LOAD$REG:  PROCEDURE! REG$N0t PTR) ; 
DECLARE  (REG$NOtPTR)  BYTE; 
CALL  LOAD$L$ID(PTR)J 

CALL  CODE$BYTE(LOD+ARITHMETIC$TYPE); 
CALL  ATTRIBUTES; 
CALL  CODE$BYTE(REG$NO)J 

END  loadSreg; 

STORE$REG:  PROCEDURE!  PTR)  ;  -4 

DECLARE  PTR  BYTE? 
CALL  LOAD$L$ID(PTR); 

CALL  CODE$BYTE(STO  +  ARITHMETI CSTYPE  -1); 
CALL  ATTRIBUTES? 
END  S TORES REG  J 
STORE$CONSTANT:  PROCEDURE  ADDRESS; 

IF(MAX£lNT$MEM:=MAX$lNT$MEM  -  VARC ( 0  )  )<NSXT$AVAILA3LE 

THEN  CALL  FATAL$ERROR(  'MO ' ) J 
CALL  BYTE$OUT(INT); 
CALL  ADDR$OUT(MAXSlNT$MEM)J 
CALL  ADDR$OUT(CON$LENGTE:=VARC(0) ); 
DC  CTR  =  1  TC  con$length; 

call  byte$0ut(7arc(ctr)); 
end; 

return  max$int$mem; 
end  store$constant; 
numeric$lit:  procedure  byte; 
declare  char  byte; 
do  ctr=1  to  varc(0); 

i?  not(  digit(char:=varc(ctr) ) 
or  (char*'-')  or  (cear='0 
or  (char-'.'))  then  return  ealsej 
end; 
return  true; 

END  NUMERICiLIT; 

alpha$lit:  procedure  byte; 

do  ctr=1  to  varc(0); 

i?  not(letter(varc(ctr)) )  then  return  false; 
end; 

return  true; 
END  alpha$lit; 

ROUND$STORE:    PROCEDURE; 
IF   VALUE(SP)O0   THEN 

do; 

call  code^byte(rnd); 

call  code$byte(l$dec); 
end; 

CALL  STORE^REG(SP-l); 

END  round^store; 
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add$sub:  procedure  ( index) j 
declare  index  byte; 
call  load$reg(0,mpp1); 

if  value(sp-3)<>0  then 

do; 

CALL  L0ADiREG(l,SP-3); 
CALL  CODEiBTTE(ADD); 

call  code$byte(sti)j 
end; 

CALL  LOAD$REG(l,SP-l); 

CALL  CODE$BYTE(ADD  +  INDEX); 

CALL  R0UND$ST0R3; 

END  addssub; 

MULT$DIV:  PROCErURE( INDEX ) ; 
DECLARE  INDEX  BYTE; 
CALL  LOAD$REG(0,MPP1) ; 
CALL  LOAD$REG(l,SP-l) ; 

call  code$byte(mul  +  index); 
call  round$store; 
end  mult$div; 

checx$subscript:  procedure; 
cur$sym=value(mp); 
if  get$type<mult$occurs  then 
do; 

call  print$error('is') ; 

return; 
end; 

if  input$numeric  then 
do; 

call  set$vahje2(get$ address  +  (get$lsngth  * 
convert$integer)); 

return; 
end; 

cur$sym=match; 
if  ( (ctr:=get$type)<numeric)  or  (ctr>com?)  then 

call  print$err0r('te')? 
call  one$addr$opp( scr, get  $ address); 
call  code$byte(subicnt); 
call  code$byte(get$length); 
call  set$value2fsub$ind); 
END  check$subscript; 

LOAD^LABEL:  PROCEDURE; 
CUR$SYM=VALUE(MP); 
IF  (A$CTR:=GET$ADDRESS)<>0  THEN 

CALL    BACK$STUFF( A$ CTR, VALUE2( MP ) ) J 
CALL   SET$ADDRESS(VALUE2(MP) ); 
CALL  SET$TYPE(LABEL$TYPE)i 
IF    ( A$CTR:=GET$FCB$ADDR)<>0    THEN 

CALL  BACK$STUFF( A$CTR ,NEXT$ AVAILABLE ) ; 
SYMBOLiADDR(FCB$ADDR)=NEXT$ AVAILABLE; 
CALL  ONE$ADDR$OP?(RET,0) J 

END  load$label; 

LOAD$SEC$LABEL:  PROCEDURE; 
A$CTR= VALUE (MP)J 


213 


call  set*value(eold$section); 

hold$section=a$ctr; 

a$ctr=value2(mp); 

call  set$value2(h0ld$seciaddr) j 

hold$sec$addr  =  a$ctr; 

call  load$labelj 

END  LOAD$SEC$LABELi 

label$addr$offset:  procedure  (addr,  hold,  offset)  address 
declare  addr  address; 
declare  (hold,  offset,  ctr)  byte; 
cur$sym=addr; 

if(ctr:=get$type)=label$type  then 
do; 

if  hold  them  return  get$ address; 

return  get$fc3$addrj 
end; 

if  ctrounresolved  then  call  i  nvalid$ty?e; 
if  hold  then 
do; 

a$ctr=get$address; 

call  set$address(next$availa3le  +  offset); 

return  a$ctr; 
end; 
a$ctr=&et$fcb$addr> 

SYMBOLS ADDR (FCB$ ADDR )=NEXT$ AVAILABLE  +  OFFSET; 
RETURN  A$CTRJ 

END  label$addr$cffset; 

LABELS ADDR:  PROCEDURE  (ADDR,  HOLD)  ADDRESS; 
DECLARE  ADDR  ADDRESS, 

HOLD  byte; 

return  label $addr$otfset  (addr,  hold,  1); 
end  label$addrj 
code$for$display:  procedure  ( pci  nt  )  j 

declare  point  byte; 

call  load$l£ld(point) j 

call  cnssaddr$opp(dis ,l$addr); 

call  code$by?e(l$length); 

if  display$flag  then  call  code$btte ( 1 ) ; 

else  call  coce$byts(0  ) ; 
display$flag=false; 
end  code$for$display; 
a$an$type:  procedure  byte; 
return  (l$type=alpha)  or  ( l$type=alpha$num) ; 
END  a$an$type; 
not^integer:  procedure  byte; 

return  l$dec<>0; 
end  not$integer; 
numeric$type:  procedure  byte; 

return  (l$type>=numeric$literal)  and  ( l$ty?e<=comp) ; 
END  numeric$type; 

GEN$COMPARE:  PROCEDURE; 

DECLARE    ( RETYPE,  H$DEC)    BYTE, 

(H$ADDR,H$LENGTH)    ADDRESS; 
CALL   LCAD^L$ID(MP); 
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l$type=and$out$occurs(l$type); 

if  c0nd^type=3  then  /*  compare  fop  numep.ic  */ 
do; 

if  a$an$type  or  (l£type>comp)  then  call  invalid5typs 

call  set$value2(next$available)j 

if  l£type=numeric  then  call  code$byte ( cnu ) j 

else  call  code$byte( cns ) ; 

call  code$address(l$addr); 

call  code$address(l$length) j 

call  set$branch; 
end; 

else  if  cond$type=4  then 
do; 

if  numepic$type  then  call  i  nvalid$ty?e; 

call  set$value2(next$available); 

call  c0de$3yte(cal); 

call  code$address(l$addr)j 

call  code$address(l$length) ; 

CALL  set$branch; 
end; 

ELS '  DO  * 

IF  NUMERIC$TY?E  then  ctr=i; 
ELSE  CTR=e; 

h$ty?e=l$type; 

h$dec=l$decj 

h$addr=l$addr; 

h$length=l$length; 

call  load*l$id(sp) ; 

if  numeric^type  then  ctr=ctr+i; 

if  ctr=2  then  /*  numeric  compare  */ 

do; 

call  load$reg(0,m?) ; 

call  set$value2(next$available-6) j 

CALL  LOAD$REG(l,SP); 

call  code$byte(sdb); 
call  code$byte(rgt  +  condstype); 
call  set$3ranchj 
end; 

ELS  E  DO  * 

/*  alpha  numeric  compare  */ 
if  (h$dec<>0)  or  (h±ty?e=comp) 
or  (i$dec<>0)  or  (l$type=comp) 
or  (h5lengthol$length)  then  call  invalid$type ; 
call  set$value2( next $ available) j 
call  code$byte(sgt+cond$type); 
call  code$address(e$addr); 
c.»ll  code$address(l$addr); 
call  code5address(h$length) ; 
call  sets3ranch; 
end; 
end; 
end  gen^compare; 
move$type:  procedure  byte? 

DECLARE 
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HOLD$TYPE  BYTE, 
ALPHA$NUM$MOVE    LIT  '0  '  , 
A$N$ED$MOVE      LIT  'l', 
NUMERIC^MOVE     LIT  '2', 
N$ED$MOVE       LIT  '3'; 

l$type=and$out$occurs (l$type); 
if( (hold$type:=and$out$occurs(get$type) )=grou?)  or 
(l$type=grcup) 

then  return  alpha$ num$move; 
if  hold*type=alpha  then 
if  a$an$ty?e  or  ( l$type=a$ed)  or  ( l$ty?e=a$n$ed  ) 

or  ((alpha$lit$?lag)  and  (l$type  =  non^numeri c$lit ) ) 

then  return  alpha$num$move; 
i?  hold$type=alpha$num  then 
do; 

if  not$integer  then  call  in valid$type ; 

return  al?ha$num$f<ove! 
end; 

if  (hold$type>=numeric)  and  ( hold$type<=comp )  then 
do; 

if  (l$type=alpha)  or  ( l$type>ccm? )  then 
CALL  invalid$type; 

return  numeric^cve; 
end; 

if  hold$type=a$n$ed  then 
do; 

if  not^integer  then  call  invalid^type ; 

return  a$n$ed$move; 
end; 
if  hold$type=a$ed  then 

if  a$an$type  or  ( l$ty?e>comp )  or  (l$ty?e 
=  n0n$numeric^lit) 

then  return  a$nied$m07e; 
if  hold$type=num$ed  then 

if  numsric$type  or  (l$typs=alpha$num)  then 
return  n^ed^move? 
CALL  invalid$ty?e; 

RETURN  0? 

END  move^type; 
gen$move-.procedure; 

DECLARE 

length1  address, 
addr1  address, 
extra  address? 
add$add*len:  procedure; 

call  c0de$addrsss(addr1); 

call  code$address(l$addr); 

call  code$address(l$lengte); 

END  ADD$ADDiLENJ 

code$for$edit:  procedure; 
call  add$add£len; 
call  code$address(get$fce$addr) ; 

CALL  CCrE$ADDRESS(LENGTHl); 
END  CODEiFOR$EDIT; 
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CALL  L0AD$L$ID(MPP1); 

CUR$SYM=VALUE(SP); 

IF  (ADDR1:=VALUE2(SP) )=0  THEN  ADDR1=GET$ADDRESS ; 

lengthi=get$length; 
do  case  move$type; 

/*  ALPHA  numeric  move  */ 

do; 
i?  length1>l$length  then  extra=length1-l$length; 
ELSE  do; 

EXTRA=0J 

L$LENGTH=LENGTHl; 

end; 

call  code$byte(mov); 

CALL  ADD$ADDiLEN; 

call  code^address(extra); 
end; 

/*  alpha  numeric  edited  */ 
do; 

call  code$byte(med)j 

CALL  code$for$edit; 
end; 

/*  numeric  move  */ 
do; 

call  l0ad$reg(2,mpp1); 

call  store$reg(sp); 

END; 

/*  numeric  edited  move  */ 

do; 
call  code$byte(mne) j 
CALL  ccde$por$edit; 
call  coee$byte(l$dec); 
call  code^byte(get$decimal); 
end; 
end; 
end  gen$mo?e; 

code$gen:  procedure! product  ion ) ; 
declare  production  byte,* 
if  ?rint*?rod  then 
do; 

call  crlf; 

call  printchar( pound); 
call  print$number(production); 
end; 

DO  CASE  production; 
/*  PRODUCTIONS*/ 
/*  CASE  0  NOT  USED  */ 
t 
/*      1  <P-DIV>  ::=  PROCEDURE  DIVISION  <USING>  . 

<PROC-BODY>  */ 

do; 

COMPILING  =  FALSE; 
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IT  SECTION^FLAG  THEM  CALL  L0AD$SEC$LA3ELt 

end; 

/*    2   <USING>  ::=  USING  <ID-STRING>  */ 

CJLL  NOT$IMPLlMENTED;   /*  INTER  PRCG  COMM  */ 
/*    3        \!  <EMPTY>  */ 

j  /*  no  action  required  */ 
/*   4  <id-string>  ::=  <id>  */ 

id$stack(id$ptr:=0)=value(sp); 
/*   5       \!  <id-string>  <id>         */ 
do; 

if(id$ptr:=idptr+1)=20  then 
do; 
call  print$error( 'id'); 

ID$PTR=19; 

end; 

id$stack( id$ptr)=v»lue(sp); 
end; 

/*   6  <?r0c-3cdy>  ::=  <paragraph>  */ 

j  /*  no  action  required  */ 

/*    7  \!  <PROC-BODY>  <PARAGRAPH>  */ 

;  /*  no  action  required  */ 

/*   8  <paragraph>  : :=  <id>  .  <sentence-list>     */ 
do; 

if  section$flag=0  then  secti0n$flag=2; 
call  load$label? 
end; 

/*   9       \!  <id>  section  .  */ 

do; 

ie  secti0n$flag<>1  then 
do; 
if  secticn$flag=2  teen  call  prlnt$error( *p?' ) » 

SECTION$FLAG=i; 
HOLDiSECTION=VALUE(M?)J 
H0LD$SEC$ADDR=7ALUE2(MP) ; 
END; 

else  cpu   load$sec$labelj 
end; 

/*   10  <sentence-list>  ::=  <sentence>  .  */ 

;  /*  no  action  required  */ 

/*      11  \!  <sentence-list>  <sentence>  .  */ 

;     /*  no  action  required  */ 

/*   12  <sentence>  : :=  <imperative>  */ 

j  /*  no  action  required  */ 
/*   13      \!  <conditional>  */ 

j  /*  no  acticn  required  */ 

/*  14      \!  enter  <id>  <opt-id>         v 
call  n0t$implimented;  /*  language  change  */ 
/*   15  <imperative>  : :=  accept  <su3id>  */ 

do; 
call  load$l$id(sp); 
call  one$addriopp(acc,l$addr)j 
call  codecs yte(lslength); 
end; 
/*   16       \!  <arithmetic>  */ 
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;   /*  NO  ACTION  REQUIRED  */ 
/*    17  \!  CALL  <LIT>  <USING>  */ 

CALL  NOT$IMPLIMENTED;   /*  INTER  PROG  COMM  */ 
/*    18  \!  CLOSE  <ID>  */ 

DO? 

declare  type  byte; 

type=get$ty?e; 

if  (type>0)  and  (type<5)  then 

call  one$addr$opp(cls,get$fcb$addr); 
else  call  print$error( 'ce' ) j 
end; 

/*        19  \!    <FILE-ACT>  */ 

j  /*  no  action  required  */ 

/*   20       \!  display  <lit/id>  <opt-lit/id>     */ 
do; 

call  code^for$display(mppl); 
ie  value(sp)<>0  then 
do; 
dis?lay$flag=true; 
call  code$for$display(sp); 
end; 
end; 

/*      21  \!  exit  <?rogram-id>  */ 

;     /*  no  action  required  */ 

/*    22  \!  GO  <ID>  */ 

call  0ne$addr$0p?(brn,la3el$addr(value(sp),1) )t 
/*   23       \!  go  <id-string>  depending  <id>     */ 
do; 

call  code$byte(gdp); 
call  code$byte(id$ptp); 
cur$sym=value(sp)j 
call  codesbyte(gftslength); 
call  code$address(get$addrsss) ; 
do  ctr=0  to  id$ptr; 

CALL 

code$ address ( label* addr$offset( i d$ stack' i d$ptr),  1,0) )j 
end; 
end; 

/*   24       \!  mote  <lit/id>  to  <su3id>      */ 
call  gen$move; 

/*   25       \!  open  <type-action>  <id>       */ 
do; 
declare  type  byte; 
type=get$type; 

if  (ty?e=1  or  ty?s=4)  and  ( value( mpp1 )<>2) 
then  call  one$addr$opp ( cpn+v alue (mpp1 ) ,get$fc3$ addr ) j 

ELSE 

if  (ty?e=2  or  type=3)  then 

call  one$addr$opp(opn+value(mppl) , & ?t^?c3*aprr ) ; 
else  call  print$error  (  'ob'  ) » 
end; 

/*      26       \!  perform  <id>  <thru>  <finish>     */ 
do; 

declare  (addr2,addr3)  address; 
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IF  VALUE(SP-1)=0 

THEN  ADDR2=LABEL$ADDR^0FFSET (VALUE (MPP1) ,0,3); 

ELSE    ADDR2=LABEL$ADDft$0FFSET(7ALUE(SP-l) ,0,3) J 

IF    ( ADDR3:=VALUE2(SP) )=0    THEN    ADDR3=N2XT$AVAILABLE 

+  ?; 
else  call  backstuff (v alue( sp ) , n ext$av aila3le  ♦  7); 
call  one$addr$opp(per,label$addr(  value (mpp1)  ,  1)  )  ; 
call  c0de$address(addr2); 
call  c0de$addp.ess(addr3); 
end; 

/*    27  \!  <READ-ID>  */ 

call  not^implimented;  /*  grammar  error  */ 

/*   28       \!  stop  <terminate>         */ 
do; 

if  7alue(sp)=0  then  call  code$byte( stp  ) ; 

ELS  E  DO  * 

callcne$addr$0pp(std,value2(sp) )5 
callcode$byte(con$length) ; 
end; 
end; 

/*   29  <conditional>  ::=  <arithmetic>  <size-error>   */ 
/*   29        <imperati7e>  */ 

CALL  back$cond; 

/*    30  \!  <FILE-ACT>  <INVALID>  <IMPERATI7E>  */ 

CALL  back$cond; 
/*   31        \t  <if-ncnterminal>  <condition> 

<action>  else  */ 
/*   31        <im?erative>  */ 

do; 

call  backstuff(7alue(mppl),valus2(s?-2)); 
call  backstuff(7alue(sp-2) , next$ available) ; 
end; 

/*   32       \!  <r2ad-id>  <special>  <imperative>  */ 
CALL  back$cond; 

/*    33   <ARITHMETIC>  : :=  ADD  <L/ID>  <OPT-L/ID>  TO 

<SUBID>  */ 
/*    33  <ROUND>  */ 

CALL  ADD$SUB(0)J 
/*    34         \!  DIVIDE  <L/ID>  INTO  <SUBID>  <RCUND>    */ 

CALL  MULT$DIV(1); 
/*    35  \!  MULTIPLY  <L/ID>  31  <SU3ID>  <ROUND>    *./ 

CALL  MULT$DIV(0); 
/*    36         \!  SUBTRACT  <L/ID>  <OPT-L/ID>  FROM      */ 
/*    36  <SUBID>  <RCUND>  */ 

CALL  ADD^SUB(l); 
/*    37   <FILE-ACT>  : :=  DELETE  <ID>  */ 

CALL  delste$a^file; 

/*    38         \!  REWRITE  <ID>  */ 

CALL  rewritesa^record; 

/*    39         \!  WRITE  <ID>  <SPEC I AL-ACT>  */ 

CALL  write$a$record; 
/*   4:0  <condition>  ::=  <lit/id>  <not>  <c0nd-typ3>   */ 

do; 
if  if^flag  then 
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do; 

if$flag=not  if$flag;         /*  reset  it$?la3  */ 
call  c0de$3yte(neg); 
end; 

call  gen$compare; 
end; 
/*   41  <cond-type>  ::=  numeric  */ 

C0ND$TY?E=3; 
/*        42  \!    ALPHABETIC  */ 

COND$TYPE=4J 
/*    43  \!  <COMPARE>  <LIT/ID>  */ 

CALL  KEEPSVALUES; 
/*    44  <NOT>  : :=  NOT  */ 

IF  NOT  IF$FLAG  THEN 

CALL  CODE$BYTE(NEG)J 

ELSE  IF$FLAG=NOT  IF^FLAG;   /*  RESET  IF$FLAG  */ 
/*    45      \!  <EMPTY>  */ 

;   /*  NO  ACTICN  REQUIRED  */ 
/*   46   <COMPARE>  : :=  GREATER  */ 

COND$TY?E=0; 
/*    47         \!  LESS  */ 

COND$TYPE=i; 
/*    48        \!  EQUAL  */ 

C0ND$TYPE=2J 
/*    49   <ROUND>  ::=  ROUNDED  */ 

CALL  SET$VALUE(1) J 
/*    50       \!  <EMPTY>  */ 

;   /*  NO  ACTION  REQUIRED  */ 
/*    51   <TERMINATE>  ::=  <LITERAL>  */ 

J   /*  NO  ACTION  REQUIRED  */ 
/*    52         \!  RUN  */ 

J   /*  NO  ACTION  REQUIRED  -  VALUE(SP)  ALREADY  ZERO  */ 
/*    53   <SPECIAL>  ::=  <INVALID>  */ 

J   /*  NO  ACTION  REQUIRED  */ 
/*    54        \!  END  */ 

do; 

call  set$value(2); 
call  code$byte(eor) ; 
CALL  set$branch; 

Tp  4]  T>  • 

/*  '55   <OPT-ID>  ::=  <SUBID>  */ 

J  /*  VALUE  AND  VAL0E2  ALREADY  SET  */ 
/*    56       \!  */ 

J  /*  VALUE  ALREADY  ZERO  */ 
/*    57   <ACTICN>  ::=  <IMPERATIVE>  */ 

CALL  unresolved^branch; 
/*   58     \!  next  sentence  */ 

call  unresclved$branch; 
/*   59  <thru>  ::=  thru  <id>  */ 

CALL  keep^values; 

/*    60      \!  */ 

;  /*  no  action  reouired  */ 
/*   61  <finish>  ::=  <l/id)  times  */ 

do; 
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CALL  LOADU$ID(MP); 
CALL  ONE$ADDP.$OPP(LDI  .LSADDP); 
CALL  CODE$BYTE(L$LENGTH); 
CALL  SET$¥ALUE2(NEXT$AVAILABLE) 
CALL  ONE$ADDR$OPP(DEC,0)t 
CALL  SET$VALUE(NEXT$AVAILABLE) J 
CALLCOEE$ADDRESS(0);   END; 
/*    62        \!  UNTIL  <CONDITION> 

CALL  KEEP$VALUES; 
/*    63        \! 
J   /*  NO  ACTION  REQUIRED  */ 


*/ 


*/ 


*/ 


/*   64  <invalid>  : :=  invalid 
do; 

call  set$value(1); 

call  code$byte(inv) ; 

CALL  set^branch; 
end; 

/*   65  <size-error>  :  :=  size  error  */ 

do; 

call  code$byte(ser); 
CALL  unresolved$branch; 
end; 

/*  66  <spscial-act>  ::=  <when>  advancing  <how-many>  */ 
call  n0t$i^plimented;  /*  carrage  control  */ 

/*    67  \!  */ 

J   /*  NO  ACTION  REQUIRED  */ 


/*    68   <VHEN>  : :=  BEFORE 
CALL  NOTSIMPLIMSNTEDJ   /*  CARRAGE 

/*    69       \  !  AFTER 
CALL  NOT$IMPLIMENTED 

/*    70   <HOW-MANY>  : 
CALL  N0T$IMPLIMENTED 

/*    71         \!  PAGE 

call  not^implimented; 
/*   72  <type-4ction> 
/*  no  action 

73 


/'*  CARRAGE 
<INTEGER> 
/*  CARRAGE 


CONTROL  */ 

*/ 
CONTROL  */ 


*/ 


» 
/* 


/*  CARRAGE 
:=  INPUT 

REQUIRED  -  VALUE'S?) 

\!  OUTPUT 


CONTROL  */ 
*/ 

CONTROL  */ 


CALL  SET$VALUS(1); 
/*    74  \!  1-0 

CALL  SST$VALUE(2); 
/*    75   <SUBID>  ::=  <SUBSCRIPT> 

;   /*  VALUE  AND  VALUE2  ALREADY  SET 
/* 


ALREADY 
*/ 

*/ 


*/ 

ZERO  */ 


*/ 


7 


76        \!  <ID> 

J   /*  NO  ACTION  REQUIRED  */ 
/*    77   <INTEGER>  : :=  <INPUT> 

CALL  SET$VALUE( CONVERTS NTEGSR) ; 
/*    78   <ID>  ::=  <INPUT> 

do; 

call  set$value( match) j 

if  get$type=unresol7ed  then 

call  set$value2(next$available) 
end; 

/*    79   <L/ID>  : :=  <IN?UT> 

do; 


*/ 


*/ 


*/ 


*/ 
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if  numeric$lit  then 
do; 
call  set$value(numeric$literal) j 
call  set  $ v alue2 ( s to re $ constant); 
end; 

else  call  set$value (match ) ; 
end; 

/*   80     \!  <su3script>  */ 

j  /*  no  action  required  */ 

/*    81       \!  ZERO  */ 

CALL  SET$VALUE(LIT$ZERO); 

/*    82   <SUBSCKIPT>  ::=  <ID>  (  <INPUT>  )        */ 

CALL  CHECK$SUBSCRIPTJ 
/*   83  <OPT-L/ID>  ::=  <L/ID>  */ 

J   /*  NO  ACTION  REQUIRED  */ 
/*   84        \!  <2MPTY>  */ 

j  /*  value  already  set  */ 
/*   85  <nn-lit>  ::=  <lit>  */ 

do; 

al?ha$lit$fla5  =  alpeaslitj 

call  sets  value (non$ numeric $lit); 

call  set$value2(st0re$c0nstant)  ; 
end; 

/*    86       \!  SPACE  */ 

CALL  SET$VALUE(LIT$SPACE) ; 
/*    87       \!  QUOTE  */ 

CALL  SET$VALUE(LIT$QUOTE); 
/*    88   <LITERAL>  :  :=  <NN-LIT>  */ 

J   /*  NO  ACTICN  REQUIRED  */ 
/*   89        \!  <INPUT>  */ 

do; 

if  not  numeric$lit  then  call  i nvalid$type; 

call  set$value(numeric$litepal) ; 

call  set$value2(st0re$c0nstant)  j 
end; 

/*  90        \!  ZERO  */ 

CALL  SET$VALUEfLIT$ZERO) ; 

/*  91   <LIT/ID>  ::=  <L/ID>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

/*  92       \!  <NN-LIT>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

/*  93   <OPT-LIT/ID>  : :=  <LIT/ID>  */ 

J  /*  NO  ACTION  REQUIRED  */ 

/*  94         \!  <EMPTY>  */ 

;  /*  NO  ACTION  REQUIRED  */ 

/*  95   <?ROGRAM-ID>  : :=  <ID>  */ 

CALL  NCTSIMPLIMENTED;   /*  INTER  PROG  COMM  */ 

/*  96         \!  */ 

5     /*  no  action  required  */ 
/*      97    <read-id>  : :=  read  <id>  */ 

call  read$a$file; 
/*      98    <if-n0nterminal>  ::=  if  */ 

if$flag  =  true;  /*  set  i?$flas  */ 

end?     /*  end  of  case  statement  */ 
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endcode$gien; 

GETIN1 -.PROCEDURE  BYTE; 

RETURN  INDEXK  STATE); 
ENDGETIN1J 
GETIN2-.PR0CEDURE  BYTE; 

RETURN  INDEX2(STATE); 
ENDGETIN2J 
INCSP:PROCEDURE; 

VALUE(SP:=SP  +  1)=0J   /*  CLEAR  THE  STACK  WHILE 

INCREMENTING  */ 

value2(sp)=0j 

ie  sp  >=  pstacksize  teen  call  fatal$ error (  'so  '  ) ; 
endincsp; 

lookahead: procedure; 
if  nolook  then 
do; 

call  scanner; 
nolook=false; 

IF  PRINT$TOKEN  then 

do; 
call  crlf; 

call  print*number(token); 
call  print$char('  ') ; 
call  print$accum; 
end; 
end; 

endlookahead; 

no$conflict:?rocedure  (cstate)  byte; 
declare  (cstate, i,j,k)  byte; 
j=index1(cstate); 
k=j  +  index2(csta.te)  -  1? 

DO  I=J  TO  z; 

if  rsadki  )=token  then  return  true? 

end; 
returnfalse; 
endno$conflict; 
recover  .-procedure  byte; 

DECLARE  ts?  byte,  rstate  byte; 

do  forever; 

TS  P=S  P  * 

DO  WHILE  TSP  <>  255; 

if  no$conflict(rstate:=statestack(ts?) )  then 
do?  /*  state  will  read  token  */ 

if  spotsp  then  s?  =  tsp  -  l; 

return  rstatsj 
end; 
TSP  =  TS?  -  1; 

end; 

call  scanner?  /*  try  another  token  */ 
end; 

endrecover; 

/*  *  *  #  *  program  execution  starts  here  *  *  */ 
/*  initialization  */ 
token=63j  /*  prime  the  scanner  with  -procedure-  */ 
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CALLMCVE(PASSl$TOP-?ASSl!?LEN,  .0UT?UT$FCB,?*SS1$LEN)  J 
/*  THIS  SETS 

OUTPUT  FILE  CONTROL  BLOCK 
TOGGLES 
READ  POINTER 

NEXT  SYMBOL  TABLE  POINTER 
*/ 
OUTPUTS  ND=  (OUTPUT$PTR:  =  .  OUTPUT!?  BUFF-1)  +  123; 
CALLPRINT$ERROR(FALSE);  /*  INITIALIZE  ERROR  MSG  OUTPUT  */ 
/*##*##*  PARSER  ******/ 

do  while  compiling; 

if  state  <=  maxrno  then    /*  read  stats  */ 
do; 

call  incsp; 

statestack(sp)  =  state;  /*  save  current  state  */ 

CALL  lookahead; 

I=GETINi; 

J  =  I  +  GETIN2  -  i; 

DO  1=1  TO  JJ 

if  read1 (i )  =  token  then 

do; 

/*  copy  the  accumulator  if  it  is  an  input 

string.  if  it  is  a  reserved  wore  it  does 

not  need  to  be  copied.  */ 

if  (token=lnput$str)  op  ( token=literal )  then 
do  k=0  to  accum(0)  ; 
varc(k)=accum(k); 
end; 
state=read2(i) ; 
nolcok=true; 
i=j; 
end; 

ELSE 

IF  I=J  T^EN 

do; 

CALL  P?INT$ERROR( 'n?'); 
CALL  FRINT( .SRRCR$NEAR$$); 
CALL  PRINT$ACCUMJ 

IF  (STATE:=RECOVEH)=0  THEN  COMPILING=FALSE ; 
END; 

end; 
end;  /*  end  of  read  state  */ 

ELSE 

if  state>maxpno  then   /*  apply  production  state  */ 
do; 

mp=s?  -  getin2; 

MPP1=MP   +    1; 

CALL  CODE$GEN( STATE  -  MAXFNO); 

sp=mp; 

I=GETINi; 
J=STATESTACK(S?) J 

DO   WHILE    (X:=APPLY1(I  )  )    <>   0    AND    JOKJ 
1=1   +   i; 

end; 
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if  (k:=apply2(i) )=0  then  compili ng=fals± \ 
state=k; 
end; 

ELSE 

if  state<=maxlno  then     /*lookahead  state*/ 
do; 

I=GETIN1J 

CALL  lookahe/d; 

DO  WHILE  (K:=L00K1(I)  )<>0  AND  TOKEN  OKJ 
I-I+lt 

end; 
state=l00k2(i  )j 
end; 

ELSE 

do;    /*push  states*/ 
call  incsp; 

statestack(sp)=getin2; 
state=getin1j 

end; 

end;/*  of  while  compiling  */ 
callbyte$out(ter); 
DOWEILE  output$ptro.output$buff; 

call  btte^out(ter); 
end; 

callclose; 
callcrlf; 

callprint(  .end$0f$part$2); 
callboot; 
end; 
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interp:    /*  module 
do; 


/* 


I    N    T    Z   R    P 


*/ 


COBOL    INTERPRETER  */ 

/*  NORMALLY    ORG'ED   TO   X'100'  */ 

/*    GLOBAL    DECLARATIONS    AND   LITERALS         */ 
DECLARE 


LIT 
BDOS 

BOOT 

CR 

LF 

TRUE 

FALSE 

FOREVER 


LITERALLY 
LIT 

LIT 
LIT 
LIT 
LIT 
LIT 
LIT 


'LITERALLY', 

'5H',      /*  ENTRY  TO  OPEPATING 
STSTEM  */ 

'0', 
'13', 
'10', 
'1', 

'WHILE  TRUE'; 


/*  UTILITY  VARIABLES  */ 
DECLARE 


BOOTSR 

INDEX 

A$CTR 

CTR 

CTR1 

BASE 

BSBYTE 

BSADDR 

HOLD 

H$BYTE 

H$ADDR 


ADDRESS 

BYTE, 

ADDRESS, 

BYTE, 

BYTE, 

ADDRESS, 

BASED  BASE  (1) 

BASED  BASE  (1) 

ADDRESS, 

BASED  HOLD  (1) 

BASED  HOLD  (1) 


INITIAL  (0000H), 


BYTE, 
ADDRESS, 

BYTE, 
ADDRESS, 


/*  CODE  POINTERS  */ 


CODE$START 
PROGRAM$ COUNTER 
CiBYTE 
C^ADDR 


'3000H', 


LIT 

ADDRESS, 

BASED  ?ROGRAM$COUNTER  (1) 

BASED  PROGRAM$COUNTER  (1) 


BYTE, 

address; 


/*****        GLOBAL    INPUT    AND    OUTPUT    ROUTINES    *   *   *   *    */ 

DECLARE 

CURRENT$FCB  ADDRESS, 

START$OFFSET        LIT        '37'; 

MON1:    PROCEDURE    (F,A)    EXTERNAL; 
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DECLARE  F  BYTE,  A  ADDRESS; 
END  MONI  J 

M0N2:  PROCEDURE  (F,A)  BYTE  EXTERNAL; 

DECLARE  F  BYTE,  A  ADDRESS; 
END  M0N2J 

?RINT$CHAR:  PROCEDURE  (CHAR); 

DECLARE  CHAR  3YTEJ 

CALL  MONI  (2, CHAR); 
END  PRINT$CHARJ 

CRLF:  PROCEDURE? 

CALL  PRINT*CEAP.(CR)  ; 

CALL    PRINT$CHAR(LF) ; 
END    CRLFJ 

PRINT:    PROCEDURE    (A); 
DECLARE    A    ADDRESS; 

CALL  crlf; 
call  moni (9, a); 

end  print; 


READ:    PROCEDURE(A); 

DECLARE    A    ADDRESS  J 
CALL    MON1(10,A); 

END  read; 


PRINT$ERROR:  PROCEDURE  (CODE); 
DECLARE  CODE  ADDRESS; 
CALL  crlf; 

CALL  PRINT$CHAR(HIGH(CODE)); 
CALL  PRINT$CHAR(LOW(CODE) ); 

END  print$error; 


FATAL$ERROR:  PROCEDURE( CODE ) ; 
DECLARE  CODE  ADDRESS; 
CALL  PRlNT$SRROR(CODE); 

CALL  booter; 
end  fatal$error; 


SET^DMA:  PROCEDURE; 

CALL  MONI  (26,  CURRENT$FCB  +  ST ART$OFFSET ) ; 

END  set$dma; 


OPEN:  PROCEDURE  (ADDR)  BYTE; 

DECLARE  ADCP.  ADDRESS; 

CALL  SET$DMA;    /*  INSURE  DIRECTORY  READ  WON' 

CL0B3ER  CORE  */ 
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RETURN  M0N2(15,ADDR); 

END  open; 


CLOSE:  PROCEDURE  (ADDR); 
DECLARE  ADDR  ADDRESS? 
IE  M0N2(16,ADDK)=255  THEN  CALL  FATAL$E?ROR (  'CL ' ) J 

END  close; 


DELETE:  PROCEDURE; 

CALL    M0N1(19,CURRENT$FCB); 

END  delete; 


make:  procedure  (addr); 

declare  addr  address; 

if  m0n2(22,addr)=255  then  call  fatal$  er?.0?.(  'me  ' )  ; 
end  make; 


DISK$READ:  PROCEDURE  BYTE? 

RETURN    MON2(20,CURRENT$?CB); 

END  disk^read; 


DISKiWRITE:    PROCEDURE  BYTE; 

RETURN    M0N2(21,CURRENT$?CB); 
END    DISK$WRITE! 


/**«**   UTILITY    PROCEDURES    *******/ 


DECLARE 

SUBSCRIPT  (9)       ADDRESS; 


RES:    PROCEDURE(ADDR)    ADDRESS; 

/*  THIS  PROCEDURE  RESOLVES  THE  ADDRESS  OF  A 
SUBSCRIPTED  IDENTIFIER  OR  A  LITERAL  CONSTANT  */ 

DECLARE  ADDR  ADDRESS,* 

IF  ADDR  >  32  THEN  RETURN  ADDR; 

IF  ADDR  <  9  THEN  RETURN  SUBS CRIPT ( ADDR ) J 

DO  CASE  ADDR  -  9; 

RETURN  .('0') 

RETURN  .('  ') 

RETURN  .('  ') 

end; 

return  e; 
END  res; 


c^v 


MOVE:  PROCEDURE  FROM .DESTINATION, COUNT); 

declare  (from, destination, count)  address, 

(f  based  from,  d  based  destination)  byte; 

do  while  (count:=count  -  1)  <>  0feffe; 
d=f; 

FROM=FROM  +  l; 

dsstination=destination  +  1j 
end; 
end  move; 


fill:  procedure (destination, count, char); 
declare  (destination, count)  address, 

(char,d  based  destination)  byte; 
do  while  (count:=ccunt  -  1)<>  0ffffh; 
d=char; 

destination=destination  +  1j 
end; 
END  fill; 


CONVERT$TO$HSX:  PROCEDURE ( POI NTER , COUNT )  ADDRESS? 
DECLARE  POINTER  ADDRESS,  COUNT  BYTE; 
A$CTR=0J 

base=pointer; 
do  ctr  =  0  to  count-1j 

a$ctr=shl(a$ctr.3)  +  shl;a$ctr.l)  +  b$byte(ctr)  -  '0'j 
end; 

return  a$ctr; 
end  convert$to$hex; 


/#  *  *  *  #  CODE  CONTROL  PROCEDURES  *****/ 

DECLARE 

BRANCH$FLAG         BITE       INITIAL(FALSE) J 

INC^PTR:  PROCEDURE  (COUNT); 
DECLARE  COUNT  3YTEJ 
PROGRAMiCOUNTER=PROGRAM$COUNTER  +  COUNT; 

END  inc$ptr; 


SET^OP^CODE:  PROCEDURE  BYTE? 
CTR=C$BYTE(0) ; 
CALL  INC$PTR(1); 
RETURN  CTRJ 

END  set^op^code; 


COND$BRANCH:  PROCEDURE* COUNT )  ; 

/*  THIS  PROCEDURE  CONTROLS  BRANCHING  INSTRUCTIONS  */ 
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declare  count  byte; 
if  branch$flag  then 
do; 

bpanch$flag=false; 

program$counter=c$addr( count) j 
end; 

else  call  inc$ptr( shl ( count, 1 )+2) ; 
END  cond$branch; 


I  NCR$OR$ BRANCH:  PROCEDURE (MARK ) J 
DECLARE  MARK  BYTE; 
IF  MARK  THEN  CALL  INC$PTR(2)J 
ELSE  PROGRAM$COUNTER=C$ADDR( 0) J 

END  incr$or$branch; 

/*****  comparisons  ********/ 


CEAR$COMPAPE:  PROCEDURE  3YTS; 

BASE=C$ADDR(0); 

HOLD=C$ADDB(l); 

DO  A$CTR=0  TO  C$ADDR(2)  -  l; 

IF  B$BYTE(A$CTR)  >  H$ BYTE ( A$CTR )  THEN  RETURN  Ij 
IF  B$BYTE(A$CTR)  <  H$BYTE( A$CTR)  THEN  RETURN  0; 

END; 

RETURN  25 

END  char^compare; 


STRING$COMPARE:  ?ROCEDURE( PIVOT) J 
DECLARE  PIVOT  BYTE? 

if  cha?.$compape=pivot  then  bpanch$flag=not  branch$flag; 
CALL  cond$branch(3); 
end  string$compare; 


NUMERIC:  PROCEDURE( CHAR )  BYTE; 

DECLARE  CHAR  BYTE; 

RETURN  (CH4R  >='0')  AND  (CHAP  <='9')J 
END  numeric; 


LETTER:  PROCEDURE ( CH»R)  BYTE; 
DECLARE  CHAR  BYTE; 
RETURN  (CHAR  >='A')  AND  (CHAR  <='Z')J 

END  letter; 


SIGN:  PROCEDURE(CHAR)  BYTE; 
DECLARE  CHAR  BYTE; 
RETURN  (CHAR='+')  OR  (CHAR='-')J 
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end  sign; 


comp$num$unsigned:  procedure? 
base=c$addr(0); 
do  a$ctr=0  to  c$addr(2)-1' 

if  not  numeric (b$byte( a$ctr) )  then 
do; 

bpanch$flag=not  branch$?lagj 

RETURN; 

end; 

END* 

call  c0nd$branch(2) ; 
end  comp$num$unsigned; 


comp$numssign:  procedure; 
base=csaddr(0); 
DO  A$CTR=0  to  c$addr(2)-i; 

if  not(numeric(ctr:=b$byte(a$ctr) ) 

or  sign(ctr) )  then 
do; 

branch$flag=not  branch$flag; 

RETURN ; 

end; 
end; 

call  cond$branch(2) ; 
end  comp$num$s ignj 


comp^alpha:  procedure; 
base=c$addr(0); 
do  a$ctr=0  to  c$addr(2)-1j 

if  not  letter ( b$ byte (a$ctr))  then 
do; 

bfanch$flag  =  not  branch$flag; 

RETURN; 

end; 
end; 

call  c0nd$brancs(2) ; 
END  ccmp$alpha; 


/*  #  *  *  *  ^NUMERIC  OPERATIONS  ******/ 


DECLARE 

(R0,R1,R2)  (10)       3YTE,  /*  REGISTERS  */ 

SIGN0(3)  BYTE, 

(DECSPT0  ,DEC$PT1 ,DEC$?T2)     BYTE, 
DECiPTA  (3)        BYTE  AT  (.DEC$?T<?), 
OVERFLOW  BYTE, 
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R$PTR 

BYTE, 

SWITCH 

BYTE, 

SIGNIF^NO 

BYTE, 

ZONE 

LIT 

'10H', 

POSITIVE 

LIT 

'l', 

NEGITIVE 

LIT 

'0'; 

CHECK$FOR$SIGN:  PROCEDURE ( CHAR )  BYTE; 

DECLARE  CHAR  BYTE; 

IE  NUMERIC (CHAR)  THEN  RETURN  POSITIVE; 

IF  NUMERIC (CHAR  -  ZONE)  THEN  RETURN  NEGITIVE; 

CALL  PRINT$ERROR('Sl')i 

RETURN  POSITIVE; 
END  CHECK$FOR$SIGNJ 


STORE*IMMEDIATE:  PROCEDURE; 
DO  CTR=0  TO  9; 

r0(ctr)=r2(ctr); 
end; 

dec$?t0=dec$pt2; 
sign0(0)=sign0(2); 
end  store^immediate; 


one$left:  procedure; 
declare  (ctr,  flag)  byte; 

if  ((flag:=shr(b$byte(0),4) )=0)  or  (flag=9)  then 
do; 

do  ctr=0  to  e; 

b $  byte ( ctr )=shl( b$byte( ctr) ,4)  or 
shr(b$byte(ctr+1),4); 
end; 

b$byte(9)=shl(b$byte(9),4)  or  flag,* 
end; 
ELSE  cverflcw=true; 

END  ONEiLEFT? 


ONE$RIGHT:  procedure; 

DECLARE  CTR  BYTE? 
CTR=10J 

do  index=i  to  9; 

CTR=CTR-i; 
B$BYTS(CTR)=SER(B$BYTE(CTR),4)  OR 

shl(b$byte(ctr-1) ,4) ; 
end; 

b$byte(0)=shr(b$byte(0) ,4)j 
if  e$byte(0)  =  09h  then 

3$BYTE(0)  =  99H; 

end  one^right; 
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shift$right:  phocedure( count 
declare  count  byte; 
do  ctr=1  to  count; 

call  one$right; 
end; 

end  shift^right; 


shift$left:  procedure  (count); 
declare  count  bytej 
overflow=false; 
do  ctr=1  to  count; 
call  one$left; 
if  07epfl0v  then  return; 
end; 
end  shift$left; 


ALLIGN:  PROCEDURE; 
BASE=.R0J 

IF  DEC$PT0  >  DEC$PT1  THEN 
CALL  SHIFT$RIGHT(DEC$?T0-DEC$PT1) ; 
ELSE  CALL  SHIFT$LEFT( DFC$PT1-DEC*PT0 ) ; 

END  allign; 


ADD$R0:  PROCEDURE( SECOND,  DEST); 

DECLARE  (SECOND,  DEST)  ADDRESS,  (CY,A,2,I,J)  BYTE 

HOLD=  second; 

BASE  =  DEST; 

CY=0? 

CTR=9J 

DO  J=l  TO  10; 

A=R0(CTR); 

B=H$BYTE(CTR); 

I=DEC(A+CY); 

cy=carry; 

i=dec(i  +  b); 

cy=(cy  or  carry)  and  1? 

b£byte(ctr)=i; 

CTR=CTR-i; 

end; 

if  cy  then 

do; 

PTT  =9  * 

DO*  J  =  1  TO  10; 

I=B$EYTE(CTR); 
I=DEC(I+CY) ; 
CY=CARRY  AND  1? 
B$BYTE(CTR)=i; 
CTR=CTR-l; 

end; 
end; 

END  ADD$R0; 
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COMPLIMENT:  PROCEDURE(NUMB ) J 
DECLARE  NUMB  BYTE; 

SIGN0(NUMB)  =  SIGN0(NUMB)  XOR  1J   /*  COMPLIMENT 

SIGN  */ 
DO  CASE  numb; 

HOLD=.R0J 

HOLD=.Ri; 

H0LD=.R2; 

end; 

DO  CTR=0  TO  9? 

h$byte(ctr)=99h  -  h$3tte(ctr); 
end; 

end  compliment; 


R2$ZER0:  PROCEDURE  BYTE  J 
DECLARE  I  BYT^* 

if  (shl(r2(0) ,4)<>0)  or  (shr( r2(9) ,4)<>0) 

then  return  false; 
else  do  1=1  to  8; 

if  r2(i)<>0  then  return  false; 
end; 
return  true; 

END  R2$ZER0; 

CHECX^RESULT:  PROCEDURE; 

IF  SHR(R2(0) f4)=9  THEN  CALL  COMPLI MENT (2)  ; 
IF  SHR(R2(0),4)<>0  THEN  OVERFLCW=TRUE J 

END  checs$result; 


check$sign:  procedure; 

if  sign0(0)  and  sisn0(1)  then 

do; 

sign0(2)=?ositive; 
return; 

end; 

sign0(2)=n3gitive; 

if  not  sign0(0)  and  not  sign0(1)  then  return; 

if  sign0(0)  then  call  compli ment( 1 ) j 

else  call  compliment! 0  )  ; 
end  checks  ign; 


LEADING$ZEROES  :  PROCEDURE  (ADDR)  BYTE; 
DECLARE  COUNT  BYTE,  ADDR  ADDRESS; 
COUNT=0J 


base=addr; 

DO  CTR=0  TO  9; 

if  (bibyte(ctr)  and  0f0h)  <>  0  then  return  count; 
count=count  +  1? 

if  (e$byte(ctr)  and  0fh)  <>  0  then  return  count; 
count=count  +  1? 
end; 

return  count; 
end  leading$zerces; 


checx$decimal:  procedure; 
if  dec$pt2<>(ctr:=c$byte(3))  then 
do; 

B AS  E=  R2  J 

if  dec$pt2  >  ctr  then  call  shift$right( dec$?t2-ctr) ; 
else  call  shift$left( ctr-dec$?t2 ) j 
end; 
if  leading$zeroes( .r2)  <  19  -  c$eyte(2)  thfn  overflow 

=  true; 
END  check$decipal; 


add:  procedure,* 

overflow=false; 

call  allign; 

call  check$sign; 

call  addr0(.ri,.R2) ; 

call  check^result; 
end  add; 


add$series:  procedure (c ount  ) ; 

declare  (i  .count)  3yte; 

do  1=1  to  count; 

call  add*r0(.r2, ,r2) j 

end; 
END  add$series; 


set$mult$div:  procedure; 

overflow=false; 

sign0(2)  =  (not  (sign0(0)  xor  sign0(1)))  and  01hj 

call  fill( .r2,10,0) j 
end  set^mult$div; 


Rl^GREATER:    PROCEDURE   BYTE; 
DECLARE    I    BYTE; 
DO    CTR=0   TO   9; 

if  rl (ctr)>(i:=99h-r0(ctr) )  then  return  true; 
if  r1(ctr)<i  then  return  false? 

end; 

return  true,* 
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end  ri$greater; 


MULTIPLY:  PROCEDURE ( VALUE  )  J 
DECLARE  VALUE  BYTE; 

IF  VALUEO0  THEN  CALL  ADD$SERIES ( VALUE ) ; 
3ASE=.R0J 

CALL  onesleft; 
END  multiply; 


DIVIDE:  PROCEDURE; 

DECLARE  (I,  J,  K,  LZ0,  LZ1,  X)  BYTE; 

CALL  SET$MULT$DIV; 

IF    (LZ0:=LEADlNG$ZERCES( ,R0) )<> 

(X  :=  (LZ1  :=  LEADING$ZEPOES ( .Rl ) ) )  THEN 

do; 

if  lz0>lz1  then 
do; 

BASE   =    .R0; 

CALL  SHIFT$LEFT(I    :=    LZ0-LZ1 ) ; 

DEC$PT0=DEC$PT0  +  I J 

X  =  lzi; 
end; 
else  do; 

BASE  =  .Rl; 

CALL  SHIFT$LSFT  ( I  :=LZ1-LZ0 ) J 

DEC$PT1=DECPT1  +  I  J 

X  =  LZ0J 

end; 
end; 

decpt2=  18  -  x  +  decpt1  -  decpt0; 
call  ccmpliment(0); 

DO  I  =  X  TO  19; 

j=0; 

DO  WHILE  RliGREATERJ 

CALL  ADD$R0( .Rl, .Rl) ; 

if  r1(0)  =  99h  then 

call  compliment  (1) j 

j=j+i; 
end; 

k=shr(i,i); 

if  i  then  r2(k)=r2(k)  or  j; 
else  r2(k)=r2(k)  or  shl(j,4); 

BASE=.R0J 

CALL  ONEiRIGH?; 

end; 
end  divide; 


LOAD$A$CEAF:  ?ROCEDURE( CH * R ) J 
DECLARE  CHAR  BYTE; 
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IF  (SWITCH:=NOT  SWITCH)  THEN 

B$BYTE(R$PTR)=B$BYTS(R$PTR)  OR  SHL(CHAR  -  30H.4); 
ELSE  B$BYTE(R$?TR:=R$?TR-1)=CHAR  -  30HJ 
END  LOAD$A$CHARJ 


load$numbers:  procedure (addf, cnt) j 

declare  addr  address,  (i,cnt)bytej 

hold=res(addr); 

ctr=cnt; 

do  index  =  1  to  cnt; 

ctr=ctr-i; 

call  load$a$char(h$byte(ctr) ); 

END; 

CALL    INC$PTR(5); 
END    LOAD^NUMBERS; 


SET$LOAD:  PROCEDURE  (SIGN$IN); 
DECLARE  SIGN^IN  BYTE; 

DO  CASE  (CTR:=C$BYTE(4) ); 
BASE=.R0; 
3ASE=.R1J 
BASE=.R2; 

end; 

dec$pta(ct3)=c$byte(3) j 
sign0(ctr)=sign$in; 
call  fill  (base, 10,0); 
r^ptr=9; 
switch=false; 
end  set$load; 


LOADiNUMERIC:  PROCEDURE; 
CALL  SETUOAD(l); 
CALL  LOAD$ NUMBERS (C$ADDR(0) , C$BYTE (2) ) ; 

END  LOAD$NUMERIC; 


LOAD$NUM$LIT:  PROCEDURE; 

DECLARE (LIT$SIZE, FLAG)  BYTE? 

CHAR$SIGN:  PROCEDURE; 

LIT$SIZE=LIT$SIZE  -  l; 

HCLD=HOLD  +  Li 
END  CHARTS  IGN; 

LIT$SIZE=C$3YTE(2); 
HOLD=C£ADDR(0)» 

IF  HiBYTS( 2)='-'  THEN 

do; 

CALL  char$sign; 

call  set$load(negitive) ; 
end; 
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ELSE    DC? 

if  h$byte(0)='+'  then  call  char$3ign; 
call  set$load(positive); 
end; 

FLAG=0; 

ctr=lit$size; 

do  index=1  to  lit$size; 

CTR=CTR-lf 

if  h$byte(ctr)='. '  then  flag=lit$si ze  -  (ctr+1); 

else  call  load$a$char ( e$3yte ( ctr ) ) j 
end; 

dec$pta(c$byte(4))=  flag; 
call  inc^ptr(5); 
END  load$nup$lit; 


STORE$ONS:  PROCEDURE; 

IF(SVITCH:=NOT  S'flTCH)  THEN 

B$BYTE(0)=SHR(H$3YTE(0) ,4)  OR  '0'; 
ELSE  do; 

HOLD=HOLD-i; 

B$BYTE(0)=(H$BYTE(0)  AND  0FH )  OR  '0'? 

end; 

BASE=BASE-1J 

END  stors^one; 


store$as<?char:  procedure( count )  ; 
declare  count  3ytej 
switch=falsf; 

E0LD=.R2  +  9; 

do  ctr=1  to  count? 

call  storeSone; 
end; 
end  store$as$char; 


set$zone:  procedure  (addr); 
declare  addr  address; 
if  not  sign0(2)  then 
do; 

base=addr; 

b$byte(0)=b$3yte(0)  or  zone; 
end; 

CALL  INCiPTR(4)J 

END  set^zone; 


sst$sign$sep:  procedure  (addr); 
declare  addr  address; 
base=addr; 

if  sign0(2)  then  3$byte(0)=' 
else  b$byte(0)='-'; 
call  inc$?tr(4); 
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END  SET$SIGN$SEP; 


STORE$NUMSRIC:  PROCErUREJ 

CALL  ceecx^decimal; 

BASE=C$ADDR(0)  +  C$BYTE(2)  -1 ; 
CALL  ST0RE£AS$CHAR(C$BYTE(2) ); 
END  STORE^NUMEPIC; 


/*#***  INPUT-OUTPUT  ACTIONS  ******/ 


DECLARE 

EOF*FLAG$OFFSET     LIT 

FLAG$OFFSET  LIT 

EXTENT$OFFSET  LIT 

REC$NO  LIT 

PTR$OFFSST  LIT 

BUFF$LENGTH  LIT 

VAR$END  LIT 

TERMINATOR  LIT 

HIGH$7ALUE  LIT 

INVALID  BYTE 

REWRITE$FLAG  BYTE 

RANDOM$FILE  BYTE 

CURRENT$FLAG  BYTE 

FCB^BYTE  BASE 

FCB$ADDR  BASE 

FCE$EYTE$A  BASE 

FC3$ADDR$A  BASE 

BUFF$PTR  ADDR 

BUFF$SND  ADDR 

BUFFSTART  ADDR 

BUFF*3YTE  BASE 

CON$BUFF  ADDR 

C0N$3YTS  BASE 

CONtlNPUT  ADDR 


'36' 
'33' 
'12' 
'32' 

'17' 

'123 
'CR' 
'1AH 
'0FFH', 

INITIAL  (0H), 


D  CURRENT$FCB 

D  CU?RENT$FCB 

D  CURRSNTSFC3  (1) 

D  CURHENT$FCB  (1) 

ESS, 

ESS, 

ESS, 

D   BUFF$PTR  BYTE, 

ESS         INITIAL    (80H)  , 

D  CON$3UFF       BYTE, 

ESS    INITIAL  (32H); 


BYTE, 

ADDRESS, 
BYTE, 
ADDRESS, 


ACCEPT:  PROCEDURE; 

CALL  crlf; 

call  print$char(3fh); 
/*  call  crlf;  */ 

call  fill(c0n^in?ut,(c0n$byte:=c*3yte(2) ) , ' 

call  rsad(con$buff) ; 

call  movs(ccn$input,res(c$addr(0) ) ,c0n$3yte); 

call  inc$ptr(3); 
END  accept; 
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display:  procedure; 

declare  b$cnt  byte; 

base=c$addr(0); 

if  not  c$byte(3)  then  call  crlf; 

b$cnt  =  c$3yte(2)j 

do  ctr  =  0  to  b$cnt  -  1j 

call  print$char(b$byte(ctr) ) 

end; 

call  inc$ptr(4)j 
END  display; 


git$file$type:  procedure  byte; 

base=c$addr<0); 

return  b$3yte(flag$cffset); 
end  get$file$type; 


set$file$type:  procedure! type ) ; 

declare  type  byte? 

base=c$addr(0); 

if  get$file$type<>0  then  call  fatal$error( 'oe' ) j 

b$byte(flag$offset)=type; 
end  set$file$type; 


SST$I$0:  procedure; 
invalid=false; 

IF  C$ADDR(0)=CURRENT$FCB   then  return; 

/*  store  current  pc  inters  and  set  internal 

write  mark  */ 
bass=current$fcb; 
fcb$addr$a(  ptrsoffset ) =3uffi ?trj 
fcb*byte$a(flag$offset)=current^flag; 
/*  load  new  values  */ 

buff $end=( buffos  tart : = ( currsnt$fcb :=c$ a  ddr (0 
+  start$offset)  +  buff^lengte; 
current$flag=fcb$byteia'vflag^offset); 
buff$ptr=fc3iaddr$a(ptrs0ffset) ; 
end  set$i$oj 


OPEN$FILE:  PROCEDURE (TYPE ) ; 
DECLARE  TYPE  BYTE; 
CALL  SET$FILE£TYPE(TYPE); 
CTR=CPEN(CURRENTiFC3:=C$ADDR(0) ); 
DO  CASE  TYPE-i; 
/*  INPUT  */ 

do; 

if  ctr=255  teen  call  fatal$error( 'nf' ) j 

end; 

/*  OUTPUT  */ 

do; 
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call  delete; 

call  make(c$addr(0)  )  ; 
end; 

;  /*  case  2  not  used  */ 
/*  i-o  */ 
do; 

ie  ctr=255  then  call  fatal$error( 'nf' )j 
end; 
end; 
fcb*byte$a(extent$offset)=0;  /*  set  the  extent  eisld 

IN  FCB  */ 

FCB$BYTE$A (REC$NO)=0J        /*  SET  THE  RECORD  NUM3SR 

IN  FCB  */ 

fcb$3yte$a(scf$flag$0ffset)=false; 

/*  set  the  eof  indicator  of?  */ 
bufiiend»(buft$start:*(current$7cb  +  3ta.rt$offset ) ) 
+  euffuength; 

current$flag=fc3$byte$a(flag$0ffset) j 
buf7$ptr,fcb$addr$a(ptr$0ffset)=buff$start-1» 
call  inc$ptr(2); 
END  open$file; 


write$mark:  procedure  byte; 
return  rol (current? flag ,1) j 

end  write^mark; 


SET$WPITE$MARK:  PROCEDURE; 

CURRENT$FLAG=CURRENT£FLAG    OR   80HJ 
END   SET$WRITE$KARX» 


WRITE$RECORD:  PROCEDURE; 
CALL  SET$DMAJ 
CURRENT$FLAG=CUR?.ENT£FLAG  AND  0FHJ 

if  (ctr:=disk$*rite)  =0  then  return; 
call  print$errcr('v3')j 

invalid=true; 
end  write$record; 


read$record:  procedure; 

call  set$dma; 

if  write$mark  then  call  write^rscord ; 

if  (ctr:=disk$read)=0  then  return? 

if  ctr=1  then  fcb$e yte^ a( ecf$flag$offset )=truej 

invalid=true; 
end  read ^record? 


read$bite:  procedure  byte; 

if  ( buff$ptr :=3uff$?tr  +  1 )  >=  3uffend  then 
do; 
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call  reads record; 

IF    ?CB$EYTESA(E0F$FLAG$0FFSET)    THEN 

RETURN  TERMINATOR; 
3UFF$?TR=BUFF$START; 

end; 

return  3uff$bytej 

END  READiBYTEJ 


write$eyte:  procedure  (char); 
declare  char  eyte; 

ie  (buff$?tr:=buff$?tr+1)  >=  buff$end  then 
do; 

call  writer re core; 
buff$ptr=9uff$start; 
if  rewrite? flag  then 
do; 

call  rsadSrecord; 

ecb$byte$a(rec$n0)=fcb$eyte$a(rec$n0)-i; 
end; 
end; 

call  set$write$mark ; 
buff$syte=char; 

END  WPITEiBYTE; 


*'RITS$END$MARK:  PROCEDURE; 
CALL  WRITE$EYTE(CR) J 
CALL  WRITESEYTE(LF) ; 

ENID   »RITE$END$MARX; 


fead$end$mar5:  procedure; 

if  read5byteccr  then  call  prl  nts  error  (  'em  ')  ; 

if  read$3yteolf  then  call  prin'tserror  [  'em  ' )  5 
end  read$end*m«fk; 


read^vari able: procedure; 
call  sets  ho? 
base=csaddr(1); 
do  a$ctr=0  to  c$addr(2)-1j 
if  (ctf:  =  (b*byte( a$ctr):=readsbyte)  )  =  varsend  teen 
do; 

ctr=read£byte; 
return; 
2nd; 

if  ctr=terminatcr  then 
do; 

fcb$byte$a(eofsflagscffse?)=tkue; 
return; 
end; 
end; 
call  read$end$mar5; 
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END  READ$VARIA3LE» 


WRITESVARIABLE:  PROCEDURE; 
DECLARE  COUNT  ADDRESS; 
CALL  SET$I<C; 
BASE=C£ADDR(1)J 
C0UNT=C$ADDR(2); 
DO  \nHILE(3$BYTE(C0UMT:=CCUNT-1)<>'  ')AND  (COUNTO0); 

end; 

do  a$ctr=0  to  count; 

call  write$byte(b*byte(a$ctr)); 
end; 

call  write$end£mark; 
?nd  writesvariable; 


READ$TO±MEMORY:  PROCEDURE; 
EASE=C$ADDR(1); 
EC  A$CTR=0  TO  C$ACDR(2)-i; 

IF  (B$*YTE(  A$CTR)  :=RSADSBYTE)=TEEMINAT0R  THEN 

do; 

fcb$byte$a(ecf$elag£offset)=true; 
return; 
end; 
ene; 

call  read$end^marx; 
end  read$to$memory; 


WRITE$FROM$MEMCRY:    PROCEDURE; 
BASE=C$ADDR(1); 
DO   AiCTR=0    TO    C$ADDR(2)-i; 

CALL  WRITE$BYTE(3$3YTE( A$CTR)  ); 

end; 

call  write$endimark5 

end  wpitesfrom$memory? 


/-  *  -  *  *  RANDOM  1-0  PROCEDURES  *  *  *  */ 


SET$RANDOM$POINTER:  PROCEDURE; 

/* 

THIS  PROCEDURE  READS  THE  RANDOM  KEY  AND  COMPUTES 

WHICH  RECORD  NEEDS  TC  BE  A7AILA3LS  IN  THE  BUFFER 

THAT  RECORD  IS  MADE  AVAILABLE  AND  THE  POINTEP5 

SET  FOR  INPUT  OR  OUTPUT 

*/ 

DECLARE  (BYTESCOUNTfRECCRD)  ADDRESS, 

EXTENT  3YTE; 
IF  WRITE$MARK  THEN  CALL  WRITEiRECORD ; 
BYTE$C0UNT=(C£ADDR(2)+2)*(CCNVERT£T0$EEX(C$ADDR(3) 
,C$BYTE(S) )-l); 
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record=ser (byte$count  ,? ) ; 

ext2nt=ser(rec0rd,7); 

if  extentofcb$byte$a(extent$0ffset)  then 

do; 

call  close(c$addr(0)); 

fc b$byt2$ a (extent $offset )=sxtent ; 

if  open(c$addr(0) )<>0  then 

do; 

ii  shr(current$flag,1)  then  call  maxe( c$ addr( 0 ) ) ; 
else  invalid=true; 

end; 
end; 

buff$ptr=(pyte$count  and  7fh)  +  buff^start  -1j 
fcb$byte$a(32)=l0w( record)  and  7fh; 
CALL  read$record; 
end  set$random^pcintsr; 

1et$rec$ number  :  procedure  address; 

declare  (record, logical$rec$num,byte$count)  address; 

record=sel(?cb$byte$a(sxtsnt$offset)  ,7) 

+  fcb$byts£a(rec$no  ); 

if  not  shr( currents pl ag, 1)  then  rec0rd=rec0rd-1 ; 

byte$c0unt=shl(rsc0rd,7)  +  ( ( 3uff$?tr+1 ) -buffsstart) j 

l0gical$rec$num=(byte*c0unt/(c$addr(2)+2) )+l» 

return  logical$rsc$nuy; 
end  get$rec$nu^ber; 

sst$relative$key:  procedure; 

declare  (rec^num,  k)  address, 

[I    c  NT  )  BYTE 

J(4)  ADDP.ESs'dATA  (10000,1000,100,1?), 
BUFF(5)  EYTEJ 
REC*NUM=GET$REC$ NUMBER? 
DO  1=0  TO  3; 
CNT=0J 

DC  XHILE  REC^NUM>=(K:=J(I )  ); 
REC$NUM=REC$NUM  -  XJ 
CNT=CNT  +  l; 

end; 

3UFF(  I)=CNT    +    '0'; 

end; 

buff;4)=rec$num+'0'; 

if  (i:=c$byte(8))<=5  then 

call  move( .buff+5-i ,c$addr(3) ,1 ); 

■g  t  5  v    DO? 

call  fill(c$addr(0) ,1-5,'   '); 

call  m0ve(.3uff,c$addr(3)+i-6.  5); 
end; 
end  set$relative$ksyj 

write$em?ty$rscord:  procedure; 
do  a$ctr=1  to  c$addr(2) j 

call  wfite$byte(eighs7alue); 
end; 
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CALL  write$end^mark; 
end  write^empty^record; 

write$dummy$records :  procedure(difference ) j 
declare  difference  address,  count  byte; 
DO  COUNT=l  TO  difference; 
CALL  WRITE$EMPTY$RECORDi 

end; 

end  write$dummy$recordsj 

back$one$extent:  procedure; 
call  closs(c$addr(0)); 
if  fcb$byte$a(extent$offset) := 
fcb$byte$a(extent$0ffset)-1=255  then 

call  fatal$err0r('w7') j 
if  cpen(c$aedr(0))<>0  then 
do; 

call  print$erro?.(  'op'); 
invalid=true; 
return; 
end; 
fc3^byte$a(rec$n0)=127; 
end  back^one^extent; 

back$one$record:  procedure; 
if(bu"ff$ptr:=3uff$ptr-(c$addr(2)+2)  )  >=3uff$start-1  then 
do; 

fcb$byte$a(rec$no)=fcb$byte$a(rec$no)-lj 

return; 
end; 
bu?f$?tr=buff$end-(buff$start-buff$ptr) ; 
if  ycb$byte£a(rec$nc)=0  then 
do; 

CALL  back$one$extent; 

IF  INVALID  THEN  RETURN  5 
CALL  READiRECORDJ 

CALL  back$one$extent; 

ent; 

ELSE 

do; 

FCB$BYTE$A(REC$NO)=FCB$BYTE$A(REC$NO  )-2J 

CALL  read^record; 
fcb$byte$a(rec$no)=fcb$byte$a(rec$no)-l; 

end; 
end  back$one$pecord; 

rewrits$seo:  procedure! flag ) ; 
declare  flag  bytej 
CALL  back$ons$record; 
rewrite$flag=true; 
if  flag-  then  call  *r ite$frcy$memory j 

/*  this  is  a  rewrite  */ 
else  call  write$empty $rscord ;  /*  this  is 

A  DELETE  */ 
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CALL  write$record; 
fcb$byte$a(rec$n0)=fcb$byte$a(rec$n0)-1j 

rewrite$flag=false; 
call  read$record; 
end  rewrite$seq; 

check$pifference:  procedure; 

declare  (difference, next$record ,next$key )  address? 
nexts record=get$rec$ number  ; 
next$key=c0nvert$t0$hex(c$addr(3),c$byte(8) ) ; 

if  next$record  >  next$key  them  call  fat  *.l$errop.(  'w2 ' )  j 
difference=next$key-next$record; 
if  difference  >  0  then 
call  write$dummy$records (difference) ; 
END  checxsdifference; 

/#    *   *    *    #    $    *    MOVES    ######    */ 


INC^HOLD:  PROCEDURE; 
HOLD=HOLD  +  15 
CTR=CTR  +  1! 

END  inc$hold; 


load^inc:  procedure; 
h$byte(0)=3$byte(0); 
base-base+1j 

CIR1=CTR1  +  1; 

call  inc^hold; 
end  loadsincj 


check$edit:  procedure( char ) j 
declare  char  byte; 

if  (char='0')  or  (char=v)  then  call  inc5holdj 
else  if  char='3'  then 
do; 

H$BYTS(0)='  '5 

call  inc$h0ld5 
end; 

else  if  char='a'  then 
do; 

IF  NOT  LETTER(B£BYTE(0) )  THEN  CALL  PR  IMT^ERRCRI  '  IC  '  )  ; 

call  load$inc; 
end; 

else  if  char- '9'  then 
do; 

if  not  numeric  (3$3yte(0))  then 

call  printsep.ror('ic')  t 

call  load$inc; 
end; 

else  call  loadsincj 
END  check$edit; 
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/#*####   MACHINE    ACTIONS    *      *#***/ 


STOP:  procedure; 

CALL  PRINT (.('END  OF  JOB  $'))» 

CALL  booter; 
END  stop; 


THE  PROCEDURE  BELOW  CONTROLS  THE  EXECUTION  OF  THE  CODE 
IT  DECODES  EACH  OP-CODE  AND  PERFORMS  THE  ACTIONS 


EXECUTE:  PROCEDURE; 

DO  forever; 

DO  CASE  GET$OP$CODE; 

;      /*  CASE  ZERO  NOT  USED  */ 
/*  01:  ADD  */ 

CALL  add; 
/*    02:    SUB    */ 


do; 


CALL    COMPLIMENT(0) ; 

IF  SIGN0(0)  THEN  SIGN0 (0 )=NEGITIVE J 

ELSE  SIGN0(0)=?OSITIVE; 

CALL  add; 


END 
/*  03:  MUL  */ 

do; 


DECLARE  I  3YTE; 
CALL  SET$MULT$DI7; 
DECPT1,DECPT2=DECPT1  +  DECPT0J 

CALL  allign; 

CALL  MULTIPLY(SHR(?.1(  I  :=9)  ,4)  ); 
DO  INDEX=1  TO  9; 

CALL  MULTIPLY (Rl( I :=I-1)  AND  0FH); 

CALL  MULTI?LY(SHR(R1(I) ,4)); 
END; 


end; 

/*  04:  DIV  */ 

CALL  divide; 


/*  05:  NEG  */ 

3RANCH$FLAG=N0T  BRANCH$FLAGJ 
/*  06:  STP  */ 

call  stop; 

/*  07:  STI  */ 

call  store$immediate; 


/*  09:  RND  */ 

do; 


end; 

/*  09:  RET  */ 

do; 


end; 

/*  10:  CLS  */ 

do; 


end 

/*  11:  SSR  */ 

do; 


CALL  store$immediate; 

CALL  FILL( .R2,10,0); 

R2(9)=i; 

CALL  add; 


if  c!>addr(0)<>0  then 
do; 

a$ctr=c$addp.{0); 

C$ADDR(0)=0J 

program$counter=a$ctr; 

end; 

else  call  inc$ptr<2); 


CALL  set$i±o; 
if  write$mark  then 
do; 
if  not  shr( current sflag ,2)  then 

call  write$byte(terminator)j 
call  *rite$rscord; 
end; 

ELSE 

call  set$dmaj 
call  close(c$addr(0)); 
fcbibite$a(flag$o?fset)=0; 
call  inc$ptr(2)j 
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IF  OVERFLOW   THEN  PROGRAM^COUNTER 
=  C$ADDR(0)J 

else  call  inc$ptr(2); 
end; 

/*  12:  BRM  */ 

PROGR AM$COUN  TER=Ci  ADDR ( 0 ) ; 
/*  13:  OPN  */ 

do; 

CALL  OPENiFILE(l); 

call  read$recordj 

end; 

/*  14:  OP1  */ 

CALL  0PEN^FILE(2)J 
/*  15:  0P2  */ 

do; 

/*  4  is  used  so  each  type  sets  only 

one  bit  in  current$flag  */ 
call  open$file(4); 
CALL  read^record; 
end; 

/*  16:  RGT  */ 

DC " 

if  not  sign0(2)  then 

branch$flag=not  branch$flagj 
call  cond$3ranch(0) j 
end; 

/*  17:  RLT  */ 


do; 
end; 

/*  18:  REO  */ 

do; 
end; 

/*  19:  INV  */ 


IF  SIGN0(2)  THEN 

BRANCH$FLAG=NOT  BRANCH$FLAGJ 
CALL  COND$BRANCH(0)> 


IF  R2$ZER0  THEN 

BRANCH$FLAG=NOT  BRANCH$FLAGJ 
CALL  COND£bRANCH(0)i 
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CALL  INCR$0R$3RANCH(INVALID); 
/*  20:  EOP  */ 

CALL    INCRiOR$BRANCH(FCB$BYTE$A(EOF$FLAG<?OFFSET) ) J 
/*  21:    ACC   */ 

call  accept; 

/*   22:    STD   */ 

do; 

C$BYTE(3)=0J 

call  display; 
call  stop; 
end; 

/*  23:  LDI  */ 

do; 

c$addr(2)=con7e?t$to$hex(c$addr(0) 

,C$BTTB(2))+li 

CALL  INC$?TR(2); 

end; 

/*  24:  LIS  */ 

call  display; 

/*  25:  DSC  */ 

do; 

if  c$addr(0)<>0  then  c$addr(0) 

=  C$ADDR(0)-1J 

if  c$addr(0)=0  then 

program^ counter  =  c$addh(1)j 
else  call  inc$ptr(4); 
end; 

/*  26:  STO  */ 

do; 


call  storesnumericj 
call  inc$ptr(4); 
end; 


/*  27:  ST1  */ 

do; 


call  store$nume?.ic; 
call  set$zcne(c$addr(0) )j 
end; 
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/*  28 


/*  29 


ST2   */ 

do; 

end; 

ST3   */ 

do; 

CALL  STORE$ NUMERIC? 

CALL  SET$ZONE(C$ADDR(0)+C$BTTE(2)-l)i 


CALL  check^decimal; 

3ASE=C$ADDR(0)    +    C$3YTE(2); 

CALL  ST0RE$AS$CHAR(C$BYTE(2)  -  1); 

CALL  SET$SIGN^SEP(C$ADDR(0)) ; 


end; 

/*  30:  ST4  */ 

do; 


call  check^decimalj 
base=c$addr(0)  +  c$3yte(2)  -1? 
call  store* as$char(c$byte(2)-1 ) j 
callset$sign$sep(c$addr(0)+c$3yte(2)-1); 
end; 


/*  31:  ST5  */ 

do; 


call  check$decimal; 

r0(9)=r2(9)  or  sign0(2); 

call  m0ve(.r2  +  9  -  c$3yte ( 2 ) , c$addr ( 0 ) 

,C$3YTE(2)); 
CALL    INC$PTRU); 


end; 

/*   32:    LOD   */ 

CALL  load$num$lit; 

/*  33:  LD1  */ 

CALL  LOAD$NUMERIC; 

/*  34=:  LD2  */ 


do; 


hold=c$addr(0) j 

i?  check$for$sign(h$3y?e(0) )  then 

do; 

call  set$load(positive); 

call  load$ numbers (c$addr(0) ,c$byte(2)); 
end; 
else  do; 

call  set$load(negitive); 
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CALL    LOAD$NUMBERS(C$ADDR(0)+1 
,C$BTTE(2)-l)j 

C  AL L   LO  AD  $  A  $  CHAR  (  H  $B  YT  E  (  0  )  -ZO  N  S  )  ,* 

end; 
end; 


/*   35:    LD3   */ 

do; 


end; 

/*   36:    LD4   */ 

do; 


end; 

/*   37:    LD5   */ 

DC- 


end; 

/*   33:    LD6   */ 

do; 


DECLARE  I  BYTE; 
HOLD=C$ADDR(0); 
IE   CHECK$EOR$SIGN ( CTR :=H$BYTE( I := 

C$BYTE(2)-1) )    THEN 
DC- 
CALL   SET$L0AD(?0SITIVE); 

1=1+1 ; 

end; 

ELS E  DO* 

CALL  SET$LOAD(NEGITIVE); 
CALL  LOAD$A$CHAR(CTR-ZONE); 

end; 

CALL  LOAD$NUMBERS(C$ADDR(0)fI)i 


HOLD=C$ADDR(0); 

IF(H$BYTE(0)='+')  THEN  CALL  SET$LOAD(l); 

ELSE  CALL  SET$LOAD(0)J 

CALL  LOAD$NUMBERS(C$ADDR(0) ,C$BYTE(2)  -1 ) ; 


HOLD=C$ADDR(0); 

IE    H$BYTE(C$BYTE(2)    -    1)    =    '+'    THEN 

CALL  SET$LOAD(l); 
ELSE  CALL  SET$LOAD(0); 
CALL    LOAD$NUMBERS(C^ADDR(0),CiBYTE(2)-l) J 


DECLARE    I    BYTE; 

HOLD=C$ADDR(0)J 

CALL  SET$LOAD(H$BYTE( I : =C$BYTE( 2 )-l ) ) J 

BASE=BASE    +9-1; 

DO   CTR    =    0    TC    i; 

B$ BYTE (CTR) =Hi BYTE (CTR); 

end; 

3$byte( ctr)=b$3yte(ctr)  and  0e0h; 
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call  inc$ptr(5)j 
end; 

/*  39:  PER  */ 

do; 

BASE=C$ADD?.(l)+i; 

b$addr(0)=c$addr(2); 
programicounter=c$addr(0) j 
end; 

/*  40:  CNU  */ 

call  ccpp$num$unsigned; 

/*  41:  CNS  */ 

call  comp£num$sign; 

/*  42:  CAL  */ 

CALL  comp$alpha; 

/*   43:    RWS    */ 

dc; 

CALL   SET$liO; 

IE   NOT   SHR(CURRENT$FLAG,2)    THEN 

CALL   FATAL$ERROR(  'W6  ' )  J 
IE   NOT   FCB$BYTE*A(EOF$FLAG$OFFSET)    THEN 

CALL    R3WRITS$S£Q(1); 
CALL    INC$PTR(6)i 

end; 

/*   44:    DLS    */ 

do; 
call  set$i$0; 
if  not  shr(current$flagt2)  then 

call  fatal$error(  'w6')j 
if  not  fcb$byte$a(eof$flag$offsst)  then 

call  rewrite$seo(0) j 
call  inc*ptr(6); 
end; 

/*  45:  RDF  */ 

do; 

call  set$i$0; 

if  not  current$flag  then 

call  fatal$err0r('¥5') ; 
if  not  fcb$3yte*a(e0f$flag<0ffset)  thin 
CALL  rsad$to<?memory; 

CALL  INC$PTR(6); 
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end; 

/*   46:    WTE   */ 

do; 

call  set$i$0; 

IF  NOT  SHR(CURR5NT$FLAGtl)  THEN 

call  eatal$err0r('w3'); 
call  write$fromSmemory; 
call  inc$ptr(6)j 
end; 

/*  47:  RVL  */ 

CALL  RE AD$ VARIABLE; 
/*  48:  WVL  */ 

CALL  VRITEiVARIABLEJ 
/*  49:  SCR  */ 

do; 

su3scri?t(c$3yte(2) )= 

convert$to$hex(c$addr(0) ,c$byte(3)); 

call  inc$ptr(4); 
end; 

/*  50:  SGT  */ 

CALL  STRING$C0MPARE(1); 
/*  51:  SLT  */ 

CALL  STRING$COMPARE(0)J 
/*  52:  SEO  */ 

CALL  STRING$C0M?ARE(2); 
/*  53:  MOV  */ 

do; 
call  m0ve(res(c$addr(1) ) , res (c £addr( 0 ) ) 

,C$ADDR(2) ); 
IE  C$ADDR(3)<>0  THEN  CALL 

FILL(RES(C$ADDR(0))  +  C$ADDS(2) 
,C$ADDR(3),'  '); 

call  inc$ptr(8) j 

end; 

/*  54:  RES  */ 

do; 
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END 


CALL  SET$I$OJ 

if  shr(current$flag,1)  then 
call  fatal$error(  "4/5')  j 
if  not  fcb$byte$a(eof$flag$offset)  teen 
do; 

call  set$relative$key; 
call  read$to$memory; 
end; 
call  inc$ptr(9)j 


/*  55:  WRS  */ 


/*  56 


do; 

call  set$i$oj 

if  not  shr(current$flag,1) 

CALL  FATAL$ERROR( 'Wl'); 

cbeck$difference; 
set$relative$key; 
write$from$memory; 

INC$PTR(9); 


THEN 


CALL 
CALL 
CALL 
CALL 
END; 
RRR 


*/ 


DC 


/*  57 


end; 

WRR  */ 


CALL  SET$I$OJ 

IF  SHR(CURRENT$FLAG,1)  THEN 
CALL  FATAL$ERR0R('W5'); 

CALL  set$random$pointer; 

IF  NOT  INVALID  THEN  CALL  READ$TO$MEMORYJ 
IF  VALID  THEN 

FCB$BYTE$A( EOF$FLAG$OFFSET  )  =  FALSE; 
CALL  INC$PTR(9)J 


do; 

declare  difference  address; 
call  set$i$0; 

if  shr(current$flag,1)  then 
do; 

call  check$difference; 

call  set$relative$key; 

call  write$?rom$memory; 
end; 

ELSE 

do; 
if  shr( currents  flag, 2)  then 
do; 

call  set$random$pointert 
if  not  invalid  then 
do; 
if  ( .buff$ptr+1)=high$value  then 
do; 
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rewrite$flag=true; 
call  writs$from$meport; 
rewrite$flag=false; 
end; 
else 

call  print$err0r(  'w4')» 
end; 

ELSE 

CALL  FATAL$ERR0R('W3')> 
END; 

end; 
call  inc$ptr(9)j 

end; 


/*  58:  RWR  */ 

do; 


CALL  S ET $ I $ 0 * 

if  not  shr(current$flag,2)  then 

call  fatal$error(  'w6')j 
revrite$flag=true; 
call  back$one$recordi 

if  not  invalid  then  call  write$?rom$memoryj 
rewrite$flag=false; 

CALL  INC$PTR(9)i 

end; 


/*  59:  DLR  */ 

do; 


end; 

/*  60:  MED  */ 

do; 


CALL  SETiI$0; 

if  not  shr(current$flag,2)  then 
call  fatal$err0r('w6'); 

call  set^randomipointerj 

rewrite$flag=true; 

if  not  invalid  then 

CALL  write$empty$record; 

rewrite$flag=false; 

CALL    INCiPTR(9); 


call  move(c$addr(3),rfs(c$addr(0) ) 

,c$addr(4)); 
base=res(c$addr(d); 
hold=res(c$addr(0)); 

CTR=0; 
CTR1=0? 

do  while  (ctr<c$addr(2))and(ctr 
<  c$addr:4)); 
call  check$edit(h$3yte(0)); 
end; 
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if  ctr  <  c$addr(4)  then 

call  ?ill(h0ld,c$addr(4)-ctr, '  ')* 
call  inc$ptr(10)j 
end; 

/*  61:  MNE  */ 

J      /*    NULL  CASE    */ 

/*  62:  GDP  */ 

do; 
declare  offset  byte? 

OFFSET=CONVERT$TO$HEX(C$ADDR(l) ,C$BYTE(l )-l) J 

if  offset  >  c$byts(0)  +  1  then 

do; 

call  print$error( 'gd')j 

call  inc$ptr(shl(c$byte(0) ,1)  +  6); 

end; 

else  program$counter=c$addr(0?fset  +  2); 
end; 

end?  /*  end  of  cass  statement  */ 
end;  /*  end  of  do  forever  */ 
END  execute; 

/***#**  program  execution  starts  here  *  *  *  */ 

base=code$start; 
program$counter=b$addr(0) 5 
call  execute; 
end; 
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READER: 

do; 

/*  cobol  compiler  -  part  2  reader  */ 

/*  this  program  is  loaded  im  with  the  part  1  program 
and  is  called  when  part  1  is  finished.  this  program 
opens  the  part2.com  file  that  contains  the  code  for 
part  2  of  the  compiler,  and  reads  it  into  core.  at 
the  end  of  the  read  operation,  control  is  passed  to 
the  second  part  program.  */ 

/*        3100h:    load  point  */ 

DECLARE 

START     LITERALLY  '100H', 

/*  STARTING  LOCATION  FOR  PART2  */ 
ADR       ADDRESS  INITIAL( START ) , 
FCB  (33)  BYTE 

INITIAL(0,  'PAPT2         COM'  ,0 ,0 ,0 , 0, 0, 0 ,0 , 0 ,0 , 0, 0 ,0 , 0 , 0 , 0 , 0 , 0 ,0 ,0 ,0, 0 ) 
INITIAL(0, 'PART2        COM' ,0 , 0 ,0 , 0,0 ,0 ,0 ,0 ,0 , 0,0 ,0,0 
,0,0,0,0,0,0,0,0)  , 

I  address; 

M0N1:    PROCEDURES, A)    EXTERNAL; 
DECLARE   F    3YTE ,    A    ADDRESS; 
END   MONi; 

M0N2:    PROCEDURES, A)BYTE   EXTERNAL; 

DECLARE  F  BYTE,  A  ADDRESS; 
END  M0N2J 

boot:  procedure  external; 
end; 

open:  procedure  (fcb)  byte; 
declare  fcb  address; 
return  m0n2  (15,  fc3)j 
end; 

read:  procedure  ( addr )  byte; 
declare  addr  address? 

call  moni  (26,  addr);  /*  set  dma  address  */ 
return  m0n2  (20,  .fcb) ;  /*  read,  and  return 


ERROR  COD*  */ 


end; 

error:  procedure (code) ; 
declare  code  address? 
call  mcn1(2,(high(c0de) )); 
call  m0n1(2,(l0w(c0de) ) )? 
call  timeu0); 


259 


CALL  eoot; 
end  error; 

call  mon1  (26,  0100h); 

/*  open  pass2.com  */ 

i?  open( .fcb)=255  then  call  err0r('02')» 
/*  read  in  file  */ 

i  =  0100hj   /*  initial  address  */ 

do  while  read(i)  =  0j  /*  read  1  sector  */ 

1=1+  0080h;  /*  bump  dma  address  */ 
end; 

call  m0n1  (26,  0080h);   /*  reset  dma  address  */ 

CALL  ADR? 
END; 
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BUILD: 

do; 

/*  normally 


ORG 'ED  AT  100H  */ 


/*  THIS  PROGRAM  TAKES  THE  CODE  OUTPUT  FROM  THE  COBOL 
COMPILER  AND  BUILDS  THE  ENVIRONMENT  FOR  THE  COBOL 
INTERPRETER  */ 


DECLARE 

LIT 
BOOT 

3D0S 

TRUE 

FALSE 

FOREVER 

FCB 

FCB$BYTE 

FCB$BYTE$A 

I 

ADDR 

CHAR 

BUFF* END 

INTERP$FCB 

CODE$NOT$SET 

READER$LOCATIO 

INTERP$ADDRESS 

INTERP$CONTENT 

UBYTE 

CODE$CTR 

CiBYTE 

BASE 

B$ADDR 

B^BYTE 


LITERALLY 

LIT 

LIT 

LIT 

LIT 

LIT 

.ADDRESS 

BASED 

BASED  FCB 

BYTE, 

ADDRESS 

BASED 

LIT 

(33) 


'0' 
'5' 
'1' 


FCB 
(33 


'LITERALLY', 
0', 

5', 
l\ 

0', 
'WHILE  TRUE'  , 

INITIAL  (5CH), 

BYTE, 

BYTE, 


INITIAL  (100H), 
ADDR  BYTE, 

'100H', 


BYTE 
N 


BYTE 

INITI 

INITI 


LIT 

ADDRESS 

BASED 

BASED 

ADDRESS, 

BASED 

ADDRESS, 

BASED 

BASED 


AL(0, 'CIMTER?  COM', 0,0, 0,0) , 

AL  (TRUE), 

'1C80H', 

INITIAL(2000H), 

INTEPP$ADDRESS  ADDRESS, 

INTERP$ADDRSSS  (2)  BYTE, 

CODE$CTR   BYTE, 

BASS      ADDRESS, 
BASS  (4)  byte; 


MON1:  PROCEDURE  (F,A)  EXTERNAL; 

DECLARE  ?  BYTE,  A  ADDRESS; 
END  MON1 J 


M0N2:  PROCEDURE  (F,A) 
DECLARE  F  BYTE,  A 
END  M0N2; 


byte  external? 
address; 


PRINT$CHAR:  ?ROCEDURE(CHAR 
DECLARE  CHAR  BYTE; 
CALL  M0N1(2,CHAR); 

END  print$char; 


CRLF:  PROCEDURE; 
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CALL  PRINT$CHAR(13) 5 
CALL  ?RINT$CEAR(10) ; 
END  CRLFJ 


PRINT:  PP.OCEDURF(A); 
DECLARE  A  ADDRESS; 

CALL  crlf; 
CALL  M0N1(9,A)» 
END  PRINT; 


OPEN:  PROCEDURE  (A)  BYTE? 
DECLARE  A  ADDRESS; 
RETURN  M0N2(15,A); 

END  open; 

REBOOT:  PROCEDURE; 

ADDR  =  boot;  CALL  addr; 
end  reboot; 


move:  procedure (from,  dest,  count); 

declare  (from,  dest,  count)  address, 

(f  based  from,  d  based  dest)  byte; 
do  while(count:=count-l )<>0ffffh; 
e=f; 

FR0M=FR0M+1J 

dest=dest+1j 
end; 
end  move; 


get$char:  procedure  byte; 

if  (addr:=addr  +  1)>=3uff$end  then 
do; 

if  mon2(20,fcb)<>0  then 
do; 

call  ?rint(.('end  of  input      $')); 
CALL  reboot; 
end; 

addr=90h; 
end; 

return  char; 
end  get$char; 


next5char:  procedure; 

char=get$char; 
end  nextschar; 


STORE:  PROCEDURE(CCUNT) J 
DECLARE  COUNT  BYTE; 
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if  code$not$set  then 
do; 

call  print(  .(/code  error$')) 

CALL  next^char; 

return; 
end; 
do  1=1  to  count; 

c$byte=char; 

CALL  NEXTiCHARt 

code$ctr=code$ctr+i; 
end; 
end  store; 


back$stuff:  procedure; 

declare  (hcld, stuff)  address 
base=.hold; 

DO  1=0  to  3; 

b$byte(i)=get$char; 
end; 
do  forever; 

base=hold; 
hold=b$addr; 
b$addr=stuff; 
if  hold=0  then 
do; 

call  next$chaf.; 
return; 
end; 
end; 
end  back$stuff; 


start$code:  procedure; 

code$not$set=false; 

i$byte(0)=get$char; 

i$byte(i)=get$char; 

ccde$ctr=interp$ con  tent; 

call  nsxt^char; 
end  start*code; 


GO$DEPENDING:  PROCEDURE; 
CALL  STORE(l); 
CALL  STORE (SHL(CHAR,1)  +  4); 

END  go$depending; 


INITIALIZE:  PROCEDURE; 

DECLARE  (COUNT, WHERE, HOW$MANY)  ADDRESS; 

BASE*. where; 

DO  1=0  TO  3; 

b$byte( i)=get$char; 
end; 
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END 


BAS"?=WHERE  -  i; 

DO  COUNT  =  1  to  how$many; 

b$byte( count )=get$ char; 
end; 

call  next$charj 
initialize; 


BUILD:  PROCEDURE; 

DECLARE 

F2 

LIT 

'8', 

F3 

LIT 

'9', 

F4 

LIT 

'21', 

F5 

LIT 

'24' 

F6 

LIT 

'32' 

F7 

LIT 

'39', 

F9 

LIT 

'49' 

P10 

LIT 

'54' 

Fll 

LIT 

'60' 

F13 

LIT 

'61' 

GDP 

LIT 

'62', 

INT 

LIT 

'63', 

3ST 

LIT 

'64' 

TER 

LIT 

'65', 

STP 

LIT 

'06', 

SCD 

LIT 

'66'; 

do  forever; 

IF  CHAR  <  F2 

THEN  CALL  STORE(l) ; 

ELSE 

IF  CHAR 

< 

F3  THEN  CALL  ST0RS(2); 

ELSE 

IF  CHAR 

< 

F4  THEN  CALL  STORE (3) J 

ELSE 

IF  CHAR 

< 

F5  THEN  CALL  STORS(4) ; 

ELSE 

IF  CHAR 

< 

F6  THEN  CALL  ST0RS(5); 

ELSE 

IF  CHAR 

< 

F7  THEN  CALL  ST0RE(6)  ; 

ELSE 

IF  CHAR 

< 

F9  THEN  CALL  ST0RE(7) ; 

ELSE 

IF  CHAR 

< 

F10  THEN  CALL  ST0RE;9); 

ELSE 

IF  CHAR 

< 

Fll  "HEN  CALL  STOhE(10); 

ELSE 

IF  CHAR 

< 

F13  TE2N  CALL  STORE(ll) 1 

ELSE 

IF  CHAR 

< 

GDP  THEM  CALL  ST0RE(13); 

ELSE 

IF  CHAR 

= 

GDP  THEN  CALL  GO$DEPENDING ; 

ELSE 

IF  CHAR 

= 

BST  THEM  CALL  3ACK$STUFF; 

ELSE 

IF  CHAR 

= 

INT  THEN  CALL  INITIALIZE; 

ELSE 

IF  CHAR 

= 

TER  THEN 

do; 

CS3YTE  - 

< 

3T?; 

CALL  PR] 

[NT( 

return; 

end; 

ELSE 

IF  CHAR 

= 

SCD  TEEN  CALL  START$CODE; 

ELSE 

do; 

IF  CHAR 

<> 

CALL  PR  I  NT (  .(  'LOAD  ERRORS' 

')); 

CALL 

next$char; 

end; 
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end; 
end  build; 


/*  program  execution  starts  here  */ 

?cb$byte$a(32)  ,fcb$byte=0; 

call  mcve(  .  ( 'cin',0,0,0,0)  ,fcb  +  9,7); 

if  0pen(fcb)=255  then 

do; 

call  print (.(  'file  not  found   $')); 

CALL  reboot; 
end; 

call  neit$char; 
call  build; 

call  move( .int5rp*fcb,fcb,33) ; 
7cb$byte$a(32)  =  0j 
if  0pen(fc3)=255  then 

DC- 
CALL  PRINT(  .( 'INTERPRETER  NOT  FOUND    $')); 

CALL  reboot; 
end; 

call  mcvs(readsrilocation,  80h ,  80h ) j 
addr  =  60e;  call  addf.j  /*  branch  to  80h  */ 
end; 
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intrdr:      /*  name  cf  module  */ 
do; 

/*  cobol  compiler  -  interp  reader  */ 

/*  this  program  is  called  ey  the  euild  program  after 
cinterp.com  has  been  opened,  and  reads  the  code  into 

MEMORY  */ 


/*   80E   -   LOAD  POINT     */ 

DECLARE 

START    LITERALLY  '100H',   /*  STARTING  LOCATION  FOR 

PART2  */ 
INTERP    ADDRESS   INITI AL(STAHT) , 

I    ADDRESS   INITIAL  (0080H); 

MONA:  PROCEDURES, A); 

DECLARE  F  BYTE,  A  ADDRESS; 
L:GO  TO  L;    /*    PATCH  TO  ->   'JMP   BDOS  '    */ 
END  mona; 

MONB:  PP0CEDURE(F,A)3YTE; 

DECLARE  F  BYTE,  A  ADDRESS; 
L:GC  TO  Li    /*    PATCH  TO  ->   "JMP   BDCS"    */ 
RETURN  0J      /*    ZAP  ->  "NO-OP"    */ 

END  MONB; 

DO  WHILE  i; 

call  mona  (26,  (i :=i+0080h) ) »  /*  set  dma  address  */ 
if   monb  (20,  5ch)  <>  0  then 

call  inter?; 
end; 

end; 
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rECOEE:   DO; 

/*  THIS  PROGRAM  TAKES  THE  CODE  OUTPUT  F?0M  THE  COBOL 
COMPILER  AND  CONVERTS  IT  INTO  A  READABLE  OUTPUT  TO 
FACILITATE  DEBUGGING  */ 


/*  *  *  100H: 


LOAD  POINT  */ 


DECLARE 

LIT 

LITERALLY 

'LITERALLY', 

BOOT 

IIT 

'0', 

BDOS 

LIT 

'5', 

FCB 

ADDRESS 

INITIAL  (5CH), 

FCB$BYTE 

BASED 

FCB 

(1)   BYTE, 

I 

BYTE, 

ADDR 

ADDRESS 

INITIAL  (100H), 

BYTE$COUNT 

ADDRESS 

INITIAL  (0), 

BYTE5LOW 

BYTE, 

BYTE$HI 

BYTE, 

CHAR 

B«SED 

ADDR 

BYTE, 

CSADDR 

BASED  ADDS 

1 

ADDRESS, 

BUFF$END 

LIT 

'em' , 

FILE$TYPE  (*)  BYTE 


DATA  ('C','I\'N'); 


MON1:  PROCEDURE  (F,A); 

DECLARE  F  BYTE,  A  ADDRESS; 

L:   GO  TO  L;    /*    PATCH  TO  JMP  5 
END  MON1 ; 


*/ 


M0N2:  PROCEDURE  (F,A)  BYTE; 

DECLARE  F  BYTE,  A  ADDRESS; 
L:GO  TO  LJ      /*  *  *    PATCH  TO 

RETURN  0; 
END  M0N2; 


JM?  5 


*/ 


PRINT^CHAR:  PROCEDURE! CHAR ) ; 
DECLARE  CHAR  BYTE; 
CALL  M0N1(2,CHAR); 

END  printschar; 


crlf:  procedure; 

call  ?rint$char(13) ; 

call  ?rint$char(10); 
end  crlf; 


P:  PROCEDURE(ADDl); 

DECLARE  ADD1  ADDRESS,  C 

CALL  crlf; 
DO  1=0  TO  2; 


3ASED  ADD1  (1)  3YTEJ 
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call  ppint$cear(c(i)) j 
end; 
call  print$char(  '  '); 

END  p; 

get$char:  procedure  byte? 

if  (addr:=addr  +  1)>buff$end  then 
do; 

if  mon2(20,fcb)<>0  then 
do; 

call  p( .(  'end')  ); 
call  time (10); 
l:  go  to  l;  /*  patch  to 
end; 

addr=80h; 
end; 

return  char; 
end  get$char; 


JMP  000? 
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D$CHAR:  procedure  (output^byte  ) ; 

declare  output$byte  byte; 

if  out?ut$byte<10  then 

call  print$ch4r(0utput$byte  +  30h); 

else  call  pr  i nt$char( outputsbyte  +  37h ) j 
end  d$char; 


PROCEDURE    (COUNT); 

DECLARE(COUNTfJ)    ADDRESS; 


DO  J 

=  1  TO 

COUNT 

i  • 

CALL 

D$CEAR(SHR(3ET$CHAR,4)); 

CALL 

D$CHAR(CHAR  AND  0FH ) J 

CALL 

PRINT$CHAE('  '); 

end; 

end  d; 

PRINT^REST:  PI 

iocedure; 

DECLARE 

F2 

LIT 

'3', 

F3 

LIT 

'9', 

F4 

LIT 

'21', 

F5 

LIT 

'23' 

F6 

LIT 

'32', 

F7 

LIT 

'39', 

F9 

LIT 

'49' 

F10 

LIT 

'54' 

Fll 

LIT 

'60', 

F13 

LIT 

'61' 

(ID? 

LIT 

'62' 

INT 

LIT 

'63', 

3ST 

LIT 

'64' 

TER 

LIT 

'65', 
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scr  LIT   '66'J 

if  char  <  f2  then  return; 

if  char  <  f3  then  doj  call  d(1)j  return;  end; 

if  char  <  f4  then  doj  call  d(2)j  return;  end; 

if  char  <  ?5  then  do;  call  d(3);  return;  end; 

if  char  <  f6  then  do?  call  d(4)j  return;  end? 

if  char  <  f7  then  doj  call  d(5)?  return?  end; 

if  char  <  f9  then  doj  call  d(6);  return;  end; 

if  char  <  f10  then  dc  j  call  d(8)»  return;  end? 

if  char  <  fll  then  do ;  call  d(9);  return;  end; 

if  char  <  f13  then  doj  call  d(10);  return;  end; 

if  char  <  gdp  then  doj  call  d(12);  return;  end; 
if  cha.p=gd?  then  doj 

call  d(l);  call  d ( shl( char , 1 ) +5 ) ;  return;  end; 

if  char  =  int  then 
do; 

byte$count  =  0; 

CALL  D(3); 
BYTE$LOW  =  CHARJ 
CALL  D(l); 

byte$hi  =  charj 

byte$count  =  btte$hij 

byte$count  =  shl (byte^count ,8 )  +  byte$l0w; 

call  d(byte$count) ; 

return; 
end; 

if  char=bst  then  do;  call  d(4);  return;  end; 
if  char=ter  then  do  j  call  p(.('end')); 
l:  go  to  l?   /*  patch  to  'jmp  0'  *  *  */  end; 
if  char=sct  then  doj  call  d(2)5  return  j  end; 
if  ceae  <>  0ffh  then  call  ?(.('xxx')); 
END  ?rint$rest; 


/*  PROGRAM  EXECUTION  STARTS  HERE  */ 

FCB$BYTE(32),  ?CB£BYTE(0)  =  0J 
DO  1=0  TO  2; 

fc3$byte(i+9)=file$ty?e(i); 
end; 

if  m0n2(15,fcb)=255  then  do;  call  p(.('zzz')); 

l:  go  to  lj  end; 

/*  *  *  *  PATCH  TO   "JMP  BOOT"'  *  *  *  */ 

DO  WHILE  l; 

IF  GET$CHAR  <=  66  THEN  DO  CASE  CHARJ 
J  /*  CASE  0  NOT  USED  */ 
CALL  Pi  .(  'ADD')  ) 
CALL  P(.(  'SUB')  ) 
CALL  P(  .(  'MUL')  ) 
CALL  P( .(  'DI7')  ) 
CALL  P(  .(  'NEG')  ) 
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CALL 
CALL 
CALL 
CALL 
CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 

CALL 


p(    I 

'ST?') 

P(.( 

'STI  'J 

P( .( 

'RND') 

P( .( 

'RET'] 

P(.( 

'CLS') 

P( .( 

'SEP/) 

p(.( 

'BRN'j 

p(.< 

'OPN'J 

P( .( 

'0P1') 

P(.< 

'0P2') 

P( .( 

'RGT', 

p(.( 

'rlt'; 

P(.( 

'REQ') 

P(.  < 

'inv; 

P(.( 

'EOR'] 

?( .( 

'acc; 

P(.( 

'STD', 

P( .( 

'LDI'] 

p( .( 

'dis'; 

P(.< 

'DEC', 

P(  .< 

'sto': 

?(.( 

'STI') 

P(.l 

,  'ST2' 

P( .( 

'ST3" 

?(.( 

;  'ST4' 

P( .( 

,  'ST5', 

P(.l 

/LOD' 

p  (     ( 

-      \     •    * 

'LDI' 

P(.< 

k'LD2'; 

P(  .1 

/LD3" 

P(. 

['LD4' 

P(. 

l'LD4' 

?( J 

;'LD6' 

p(. 

:  'per', 

P(. 

;'cnu' 

P(. 

;'cns' 

p( . 

/CAL', 

?( . 

{  'RWS' 

p(. 

('DLS' 

p( . 

;  'rdj' 

P(. 

[  'WTF' 

P( . 

Crvl' 

p(. 

(  'WVL' 

?  (  ♦ 

('SCR' 

P( . 

(  'SOT' 

P( . 

CSLT' 

p  ( 

• 

('SEQ' 

P(. 

(  >07' 

p  f 

(  'RRS' 

P(. 

('wrs' 

P( . 

(  'RRR' 

p(. 

(  'WRR' 

P(. 

(  'RWR' 

CDLR' 
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CALL  P(.(  'MED' 
CALL  P(.( 'MNE' 
CALL  P(  .(  'GDP' 
CALL  P(.( 'INT' 
CALL  P(.(  'BST' 
CALL  P(.( 'TER' 
CALL  P(.( 'SCD' 
END;  /*  OF  CASE  STATEMENT 

CALL  print$rest; 
end?  /*  end  of  do  while  */ 
end; 


*/ 
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